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 6 bits and use the bottom 2 for build
 184     # options most likely to cause incompatibilities.  Breaks at Perl 5.64.
 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 <<= 2;
 192     $ver += 1 if $debugging_enabled;    # If DEBUGGING is set
 193     $ver += 2 if $use_threads;          # if we're threaded
 194     print OPTBLD "GSMATCH=$gsmatch,$ver,$sub\n";
 195   }
 196   else {
 197     my $major = int($] * 1000)                        & 0xFF;  # range 0..255
 198     my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF;  # range 0..255
 199     print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n";
 200   }
 201 }
 202 elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); }
 203 # Include object modules and RTLs in options file
 204 # Linker wants /Include and /Library on different lines
 205 print OPTBLD "$libperl/Include=($incstr)\n";
 206 print OPTBLD "$libperl/Library\n";
 207 open(RTLOPT,'<',$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n";
 208 while (<RTLOPT>) { print OPTBLD; }
 209 close RTLOPT;
 210 close OPTBLD;
 211
 212
 213 # Symbol shortening Copyright (c) 2012 Craig A. Berry
 214 #
 215 # Released under the same terms as Perl itself.
 216 #
 217 # This code provides shortening of long symbols (> 31 characters) using the
 218 # same mechanism as the OpenVMS C compiler.  The basic procedure is to compute
 219 # an AUTODIN II checksum of the entire symbol, encode the checksum in base32,
 220 # and glue together a shortened symbol from the first 23 characters of the
 221 # original symbol plus the encoded checksum appended.  The output format is
 222 # the same used in the name mangler database, stored by default in
 223 # [.CXX_REPOSITORY]CXX$DEMANGLER_DB.
 224
 225 sub crc32 {
 226     use constant autodin_ii_table => [
 227         0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, 0x706af48f,
 228         0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, 0xe0d5e91e, 0x97d2d988,
 229         0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, 0x90bf1d91, 0x1db71064, 0x6ab020f2,
 230         0xf3b97148, 0x84be41de, 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7,
 231         0x136c9856, 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
 232         0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, 0xa2677172,
 233         0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, 0x35b5a8fa, 0x42b2986c,
 234         0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, 0x45df5c75, 0xdcd60dcf, 0xabd13d59,
 235         0x26d930ac, 0x51de003a, 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423,
 236         0xcfba9599, 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924,
 237         0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, 0x01db7106,
 238         0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, 0x9fbfe4a5, 0xe8b8d433,
 239         0x7807c9a2, 0x0f00f934, 0x9609a88e, 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d,
 240         0x91646c97, 0xe6635c01, 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e,
 241         0x6c0695ed, 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950,
 242         0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, 0xfbd44c65,
 243         0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, 0x4adfa541, 0x3dd895d7,
 244         0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, 0x346ed9fc, 0xad678846, 0xda60b8d0,
 245         0x44042d73, 0x33031de5, 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa,
 246         0xbe0b1010, 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f,
 247         0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, 0x2eb40d81,
 248         0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, 0x03b6e20c, 0x74b1d29a,
 249         0xead54739, 0x9dd277af, 0x04db2615, 0x73dc1683, 0xe3630b12, 0x94643b84,
 250         0x0d6d6a3e, 0x7a6a5aa8, 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1,
 251         0xf00f9344, 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb,
 252         0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, 0x67dd4acc,
 253         0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, 0xd6d6a3e8, 0xa1d1937e,
 254         0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, 0xa6bc5767, 0x3fb506dd, 0x48b2364b,
 255         0xd80d2bda, 0xaf0a1b4c, 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55,
 256         0x316e8eef, 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236,
 257         0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, 0xb2bd0b28,
 258         0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, 0x2cd99e8b, 0x5bdeae1d,
 259         0x9b64c2b0, 0xec63f226, 0x756aa39c, 0x026d930a, 0x9c0906a9, 0xeb0e363f,
 260         0x72076785, 0x05005713, 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38,
 261         0x92d28e9b, 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242,
 262         0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, 0x18b74777,
 263         0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, 0x8f659eff, 0xf862ae69,
 264         0x616bffd3, 0x166ccf45, 0xa00ae278, 0xd70dd2ee, 0x4e048354, 0x3903b3c2,
 265         0xa7672661, 0xd06016f7, 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc,
 266         0x40df0b66, 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9,
 267         0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, 0xcdd70693,
 268         0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, 0x5d681b02, 0x2a6f2b94,
 269         0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, 0x2d02ef8d,
 270     ];
 271
 272     my $input_string = shift;
 273     my $crc = 0xFFFFFFFF;
 274
 275     for my $byte (unpack 'C*', $input_string) {
 276         $crc = ($crc >> 8) ^ autodin_ii_table->[($crc ^ $byte) & 0xff];
 277     }
 278     return ~$crc;
 279 }
 280
 281 sub base32 {
 282     my $input = shift;
 283     my $output = '';
 284     use constant base32hex_table => [
 285         '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
 286         'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
 287         'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
 288         'u', 'v'
 289     ];
 290
 291     # Grab lowest 5 bits and look up conversion in table.  Lather, rinse,
 292     # repeat for a total of 7, 5-bit chunks to accommodate 32 bits of input.
 293
 294     for (0..6) {
 295         $output  = base32hex_table->[$input & 0x1f] . $output;
 296         $input >>= 5;     # position to look at next 5
 297     }
 298     $output .= '$';       #  It's DEC, so use '$' not '=' to pad.
 299
 300     return $output;
 301 }
 302
 303 sub shorten_symbol {
 304     my $input_symbol = shift;
 305     my $as_is_flag = shift;
 306     my $symbol = $input_symbol;
 307
 308     return $symbol unless length($input_symbol) > 31;
 309
 310     $symbol = uc($symbol) unless $as_is_flag;
 311     my $crc = crc32($symbol);
 312     $crc = ~$crc;  # Compiler uses non-inverted form.
 313     my $b32 = base32($crc);
 314     $b32 = uc($b32) unless $as_is_flag;
 315
 316     return substr($symbol, 0, 23) . $b32;
 317 }
 318
 319 __END__
 320