vms/gen_shrfls.pl

   1 # Create global symbol declarations, transfer vector, and
   2 # linker options files for PerlShr.
   3 #
   4 # Processes the output of makedef.pl.
   5 #
   6 # Input:
   7 #    $cc_cmd - compiler command
   8 #    $objsuffix - file type (including '.') used for object files.
   9 #    $libperl - Perl object library.
  10 #    $extnames - package names for static extensions (used to generate
  11 #        linker options file entries for boot functions)
  12 #    $rtlopt - name of options file specifying RTLs to which PerlShr.Exe
  13 #        must be linked
  14 #
  15 # Output:
  16 #    PerlShr_Attr.Opt - linker options file which specifies that global vars
  17 #        be placed in NOSHR,WRT psects.  Use when linking any object files
  18 #        against PerlShr.Exe, since cc places global vars in SHR,WRT psects
  19 #        by default.
  20 #    PerlShr_Bld.Opt - declares universal symbols for PerlShr.Exe
  21 #
  22 # To do:
  23 #   - figure out a good way to collect global vars in one psect, given that
  24 #     we can't use globaldef because of gcc.
  25 #   - then, check for existing files and preserve symbol and transfer vector
  26 #     order for upward compatibility
  27 #   - then, add GSMATCH to options file - but how do we insure that new
  28 #     library has everything old one did
  29 #     (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)?
  30 #
  31 # Author: Charles Bailey  bailey@newman.upenn.edu
  32
  33 use strict;
  34 require 5.000;
  35
  36 my $debug = $ENV{'GEN_SHRFLS_DEBUG'};
  37
  38 print "gen_shrfls.pl Rev. 8-Jul-2011\n" if $debug;
  39
  40 if ($ARGV[0] eq '-f') {
  41   open(INP,'<',$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n";
  42   print "Input taken from file $ARGV[1]\n" if $debug;
  43   @ARGV = ();
  44   while (<INP>) {
  45     chomp;
  46     push(@ARGV,split(/\|/,$_));
  47   }
  48   close INP;
  49   print "Read input data | ",join(' | ',@ARGV)," |\n" if $debug > 1;
  50 }
  51
  52 my $cc_cmd = shift @ARGV; # no longer used to run the preprocessor
  53
  54 print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug;
  55 my $docc = ($cc_cmd !~ /^~~/);
  56 print "\$docc = $docc\n" if $debug;
  57
  58 my ( $use_threads, $use_mymalloc, $care_about_case, $shorten_symbols,
  59      $debugging_enabled, $hide_mymalloc, $isgcc, $use_perlio, $dir )
  60    = ( 0, 0, 0, 0, 0, 0, 0, 0 );
  61
  62 if (-f 'perl.h') { $dir = '[]'; }
  63 elsif (-f '[-]perl.h') { $dir = '[-]'; }
  64 else { die "$0: Can't find perl.h\n"; }
  65
  66 # Go see what is enabled in config.sh
  67 my $config = $dir . "config.sh";
  68 open CONFIG, '<', $config;
  69 while(<CONFIG>) {
  70     $use_threads++ if /usethreads='(define|yes|true|t|y|1)'/i;
  71     $use_mymalloc++ if /usemymalloc='(define|yes|true|t|y|1)'/i;
  72     $care_about_case++ if /d_vms_case_sensitive_symbols='(define|yes|true|t|y|1)'/i;
  73     $shorten_symbols++ if /d_vms_shorten_long_symbols='(define|yes|true|t|y|1)'/i;
  74     $debugging_enabled++ if /usedebugging_perl='(define|yes|true|t|y|1)'/i;
  75     $hide_mymalloc++ if /embedmymalloc='(define|yes|true|t|y|1)'/i;
  76     $isgcc++ if /gccversion='[^']/;
  77     $use_perlio++ if /useperlio='(define|yes|true|t|y|1)'/i;
  78 }
  79 close CONFIG;
  80
  81 # put quotes back onto defines - they were removed by DCL on the way in
  82 if (my ($prefix,$defines,$suffix) =
  83          ($cc_cmd =~ m#(.*)/Define=(.*?)([/\s].*)#i)) {
  84   $defines =~ s/^\((.*)\)$/$1/;
  85   $debugging_enabled ||= $defines =~ /\bDEBUGGING\b/;
  86   my @defines = split(/,/,$defines);
  87   $cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines))
  88               . ')' . $suffix;
  89 }
  90 print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug;
  91
  92 # check for gcc - if present, we'll need to use MACRO hack to
  93 # define global symbols for shared variables
  94
  95 print "\$isgcc: $isgcc\n" if $debug;
  96 print "\$debugging_enabled: $debugging_enabled\n" if $debug;
  97
  98 my $objsuffix = shift @ARGV;
  99 print "\$objsuffix: \\$objsuffix\\\n" if $debug;
 100 my $dbgprefix = shift @ARGV;
 101 print "\$dbgprefix: \\$dbgprefix\\\n" if $debug;
 102 my $olbsuffix = shift @ARGV;
 103 print "\$olbsuffix: \\$olbsuffix\\\n" if $debug;
 104 my $libperl = "${dbgprefix}libperl$olbsuffix";
 105 my $extnames = shift @ARGV;
 106 print "\$extnames: \\$extnames\\\n" if $debug;
 107 my $rtlopt = shift @ARGV;
 108 print "\$rtlopt: \\$rtlopt\\\n" if $debug;
 109
 110 my (%vars, %fcns);
 111
 112 open my $makedefs, '<', $dir . 'makedef.lis' or die "Unable to open makedef.lis: $!";
 113
 114 while (my $line = <$makedefs>) {
 115   chomp $line;
 116   $line = shorten_symbol($line, $care_about_case) if $shorten_symbols;
 117   # makedef.pl loses distinction between vars and funcs, so
 118   # use the start of the name to guess and add specific
 119   # exceptions when we know about them.
 120   if ($line =~ m/^(PL_|MallocCfg)/
 121       || $line eq 'PerlIO_perlio'
 122       || $line eq 'PerlIO_pending') {
 123     $vars{$line}++;
 124   }
 125   else {
 126     $fcns{$line}++;
 127   }
 128 }
 129
 130 if ($debugging_enabled and $isgcc) { $vars{'colors'}++ }
 131 foreach (split /\s+/, $extnames) {
 132   my($pkgname) = $_;
 133   $pkgname =~ s/::/__/g;
 134   $fcns{"boot_$pkgname"}++;
 135   print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug;
 136 }
 137
 138 # Eventually, we'll check against existing copies here, so we can add new
 139 # symbols to an existing options file in an upwardly-compatible manner.
 140
 141 my $marord = 1;
 142 open(OPTBLD,'>', "${dir}${dbgprefix}perlshr_bld.opt")
 143   or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n";
 144
 145 unless ($isgcc) {
 146   print OPTBLD "PSECT_ATTR=LIB\$INITIALIZE,GBL,NOEXE,NOWRT,NOSHR,LONG\n";
 147 }
 148 print OPTBLD "case_sensitive=yes\n" if $care_about_case;
 149 my $count = 0;
 150 foreach my $var (sort (keys %vars)) {
 151   print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n";
 152 }
 153
 154 foreach my $func (sort keys %fcns) {
 155   print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n";
 156 }
 157
 158 open(OPTATTR, '>', "${dir}perlshr_attr.opt")
 159   or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
 160 if ($isgcc) {
 161 # TODO -- lost ability to distinguish constant vars from others when
 162 # we switched to using makedef.pl for input.
 163 #  foreach my $var (sort keys %cvars) {
 164 #    print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n";
 165 #  }
 166   foreach my $var (sort keys %vars) {
 167     print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
 168   }
 169 }
 170 else {
 171   print OPTATTR "! No additional linker directives are needed when using DECC\n";
 172 }
 173 close OPTATTR;
 174
 175 my $incstr = 'PERL,GLOBALS';
 176 my (@symfiles, $drvrname);
 177
 178 # Initial hack to permit building of compatible shareable images for a
 179 # given version of Perl.
 180 if ($ENV{PERLSHR_USE_GSMATCH}) {
 181   if ($ENV{PERLSHR_USE_GSMATCH} eq 'INCLUDE_COMPILE_OPTIONS') {
 182     # Build up a major ID. Since on Alpha it can only be 8 bits, we encode
 183     # the version number in the top 5 bits and use the bottom 3 for build
 184     # options most likely to cause incompatibilities.  Breaks at Perl 5.32.
 185     my ($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d\d)/;
 186     $ver += 0; $sub += 0;
 187     my $gsmatch = ($ver % 2 == 1) ? "EQUAL" : "LEQUAL"; # Force an equal match for
 188                                                   # dev, but be more forgiving
 189                                                   # for releases
 190
 191     $ver <<= 3;
 192     $ver += 1 if $debugging_enabled;    # If DEBUGGING is set
 193     $ver += 2 if $use_threads;          # if we're threaded
 194     $ver += 4 if $use_mymalloc;         # if we're using perl's malloc
 195     print OPTBLD "GSMATCH=$gsmatch,$ver,$sub\n";
 196   }
 197   else {
 198     my $major = int($] * 1000)                        & 0xFF;  # range 0..255
 199     my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF;  # range 0..255
 200     print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n";
 201   }
 202 }
 203 elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); }
 204 # Include object modules and RTLs in options file
 205 # Linker wants /Include and /Library on different lines
 206 print OPTBLD "$libperl/Include=($incstr)\n";
 207 print OPTBLD "$libperl/Library\n";
 208 open(RTLOPT,'<',$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n";
 209 while (<RTLOPT>) { print OPTBLD; }
 210 close RTLOPT;
 211 close OPTBLD;
 212
 213
 214 # Symbol shortening Copyright (c) 2012 Craig A. Berry
 215 #
 216 # Released under the same terms as Perl itself.
 217 #
 218 # This code provides shortening of long symbols (> 31 characters) using the
 219 # same mechanism as the OpenVMS C compiler.  The basic procedure is to compute
 220 # an AUTODIN II checksum of the entire symbol, encode the checksum in base32,
 221 # and glue together a shortened symbol from the first 23 characters of the
 222 # original symbol plus the encoded checksum appended.  The output format is
 223 # the same used in the name mangler database, stored by default in
 224 # [.CXX_REPOSITORY]CXX$DEMANGLER_DB.
 225
 226 sub crc32 {
 227     use constant autodin_ii_table => [
 228         0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, 0x706af48f,
 229         0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, 0xe0d5e91e, 0x97d2d988,
 230         0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, 0x90bf1d91, 0x1db71064, 0x6ab020f2,
 231         0xf3b97148, 0x84be41de, 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7,
 232         0x136c9856, 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
 233         0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, 0xa2677172,
 234         0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, 0x35b5a8fa, 0x42b2986c,
 235         0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, 0x45df5c75, 0xdcd60dcf, 0xabd13d59,
 236         0x26d930ac, 0x51de003a, 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423,
 237         0xcfba9599, 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924,
 238         0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, 0x01db7106,
 239         0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, 0x9fbfe4a5, 0xe8b8d433,
 240         0x7807c9a2, 0x0f00f934, 0x9609a88e, 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d,
 241         0x91646c97, 0xe6635c01, 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e,
 242         0x6c0695ed, 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950,
 243         0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, 0xfbd44c65,
 244         0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, 0x4adfa541, 0x3dd895d7,
 245         0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, 0x346ed9fc, 0xad678846, 0xda60b8d0,
 246         0x44042d73, 0x33031de5, 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa,
 247         0xbe0b1010, 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f,
 248         0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, 0x2eb40d81,
 249         0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, 0x03b6e20c, 0x74b1d29a,
 250         0xead54739, 0x9dd277af, 0x04db2615, 0x73dc1683, 0xe3630b12, 0x94643b84,
 251         0x0d6d6a3e, 0x7a6a5aa8, 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1,
 252         0xf00f9344, 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb,
 253         0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, 0x67dd4acc,
 254         0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, 0xd6d6a3e8, 0xa1d1937e,
 255         0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, 0xa6bc5767, 0x3fb506dd, 0x48b2364b,
 256         0xd80d2bda, 0xaf0a1b4c, 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55,
 257         0x316e8eef, 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236,
 258         0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, 0xb2bd0b28,
 259         0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, 0x2cd99e8b, 0x5bdeae1d,
 260         0x9b64c2b0, 0xec63f226, 0x756aa39c, 0x026d930a, 0x9c0906a9, 0xeb0e363f,
 261         0x72076785, 0x05005713, 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38,
 262         0x92d28e9b, 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242,
 263         0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, 0x18b74777,
 264         0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, 0x8f659eff, 0xf862ae69,
 265         0x616bffd3, 0x166ccf45, 0xa00ae278, 0xd70dd2ee, 0x4e048354, 0x3903b3c2,
 266         0xa7672661, 0xd06016f7, 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc,
 267         0x40df0b66, 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9,
 268         0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, 0xcdd70693,
 269         0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, 0x5d681b02, 0x2a6f2b94,
 270         0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, 0x2d02ef8d,
 271     ];
 272
 273     my $input_string = shift;
 274     my $crc = 0xFFFFFFFF;
 275
 276     for my $byte (unpack 'C*', $input_string) {
 277         $crc = ($crc >> 8) ^ autodin_ii_table->[($crc ^ $byte) & 0xff];
 278     }
 279     return ~$crc;
 280 }
 281
 282 sub base32 {
 283     my $input = shift;
 284     my $output = '';
 285     use constant base32hex_table => [
 286         '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
 287         'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
 288         'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
 289         'u', 'v'
 290     ];
 291
 292     # Grab lowest 5 bits and look up conversion in table.  Lather, rinse,
 293     # repeat for a total of 7, 5-bit chunks to accommodate 32 bits of input.
 294
 295     for (0..6) {
 296         $output  = base32hex_table->[$input & 0x1f] . $output;
 297         $input >>= 5;     # position to look at next 5
 298     }
 299     $output .= '$';       #  It's DEC, so use '$' not '=' to pad.
 300
 301     return $output;
 302 }
 303
 304 sub shorten_symbol {
 305     my $input_symbol = shift;
 306     my $as_is_flag = shift;
 307     my $symbol = $input_symbol;
 308
 309     return $symbol unless length($input_symbol) > 31;
 310
 311     $symbol = uc($symbol) unless $as_is_flag;
 312     my $crc = crc32($symbol);
 313     $crc = ~$crc;  # Compiler uses non-inverted form.
 314     my $b32 = base32($crc);
 315     $b32 = uc($b32) unless $as_is_flag;
 316
 317     return substr($symbol, 0, 23) . $b32;
 318 }
 319
 320 __END__
 321