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