[perl5.git] / vms / gen_shrfls.pl

# Create global symbol declarations, transfer vector, and
# linker options files for PerlShr.
#
# Processes the output of makedef.pl.
#
# Input:
#    $cc_cmd - compiler command
#    $objsuffix - file type (including '.') used for object files.
#    $libperl - Perl object library.
#    $extnames - package names for static extensions (used to generate
#        linker options file entries for boot functions)
#    $rtlopt - name of options file specifying RTLs to which PerlShr.Exe
#        must be linked
#
# Output:
#    PerlShr_Attr.Opt - linker options file which specifies that global vars
#        be placed in NOSHR,WRT psects.  Use when linking any object files
#        against PerlShr.Exe, since cc places global vars in SHR,WRT psects
#        by default.
#    PerlShr_Bld.Opt - declares universal symbols for PerlShr.Exe
#    Perlshr_Gbl*.Mar, Perlshr_Gbl*.Obj (VAX  only) - declares global symbols
#        for global vars (done here because gcc can't globaldef) and creates
#        transfer vectors for routines on a VAX.
#    PerlShr_Gbl.Opt (VAX only) - list of PerlShr_Gbl*.Obj, used for input
#        to the linker when building PerlShr.Exe.
#
# To do:
#   - figure out a good way to collect global vars in one psect, given that
#     we can't use globaldef because of gcc.
#   - then, check for existing files and preserve symbol and transfer vector
#     order for upward compatibility
#   - then, add GSMATCH to options file - but how do we insure that new
#     library has everything old one did
#     (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)?
#
# Author: Charles Bailey  bailey@newman.upenn.edu

use strict;
require 5.000;

my $debug = $ENV{'GEN_SHRFLS_DEBUG'};

print "gen_shrfls.pl Rev. 8-Jul-2011\n" if $debug;

if ($ARGV[0] eq '-f') {
  open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n";
  print "Input taken from file $ARGV[1]\n" if $debug;
  @ARGV = ();
  while (<INP>) {
    chomp;
    push(@ARGV,split(/\|/,$_));
  }
  close INP;
  print "Read input data | ",join(' | ',@ARGV)," |\n" if $debug > 1;
}

my $cc_cmd = shift @ARGV; # no longer used to run the preprocessor

# Someday, we'll have $GetSyI built into perl . . .
my $isvax = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .LE. 1024 .AND. F\$GetSyI(\"HW_MODEL\") .GT. 0\)`;
chomp $isvax;
print "\$isvax: \\$isvax\\\n" if $debug;

print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug;
my $docc = ($cc_cmd !~ /^~~/);
print "\$docc = $docc\n" if $debug;

my ( $use_threads, $use_mymalloc, $care_about_case, $shorten_symbols,
     $debugging_enabled, $hide_mymalloc, $isgcc, $use_perlio, $dir )
   = ( 0, 0, 0, 0, 0, 0, 0, 0 );

if (-f 'perl.h') { $dir = '[]'; }
elsif (-f '[-]perl.h') { $dir = '[-]'; }
else { die "$0: Can't find perl.h\n"; }

# Go see what is enabled in config.sh
my $config = $dir . "config.sh";
open CONFIG, '<', $config;
while(<CONFIG>) {
    $use_threads++ if /usethreads='(define|yes|true|t|y|1)'/i;
    $use_mymalloc++ if /usemymalloc='(define|yes|true|t|y|1)'/i;
    $care_about_case++ if /d_vms_case_sensitive_symbols='(define|yes|true|t|y|1)'/i;
    $shorten_symbols++ if /d_vms_shorten_long_symbols='(define|yes|true|t|y|1)'/i;
    $debugging_enabled++ if /usedebugging_perl='(define|yes|true|t|y|1)'/i;
    $hide_mymalloc++ if /embedmymalloc='(define|yes|true|t|y|1)'/i;
    $isgcc++ if /gccversion='[^']/;
    $use_perlio++ if /useperlio='(define|yes|true|t|y|1)'/i;
}
close CONFIG;
  
# put quotes back onto defines - they were removed by DCL on the way in
if (my ($prefix,$defines,$suffix) =
         ($cc_cmd =~ m#(.*)/Define=(.*?)([/\s].*)#i)) {
  $defines =~ s/^\((.*)\)$/$1/;
  $debugging_enabled ||= $defines =~ /\bDEBUGGING\b/;
  my @defines = split(/,/,$defines);
  $cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines)) 
              . ')' . $suffix;
}
print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug;

# check for gcc - if present, we'll need to use MACRO hack to
# define global symbols for shared variables

print "\$isgcc: $isgcc\n" if $debug;
print "\$debugging_enabled: $debugging_enabled\n" if $debug;

my $objsuffix = shift @ARGV;
print "\$objsuffix: \\$objsuffix\\\n" if $debug;
my $dbgprefix = shift @ARGV;
print "\$dbgprefix: \\$dbgprefix\\\n" if $debug;
my $olbsuffix = shift @ARGV;
print "\$olbsuffix: \\$olbsuffix\\\n" if $debug;
my $libperl = "${dbgprefix}libperl$olbsuffix";
my $extnames = shift @ARGV;
print "\$extnames: \\$extnames\\\n" if $debug;
my $rtlopt = shift @ARGV;
print "\$rtlopt: \\$rtlopt\\\n" if $debug;

my (%vars, %fcns);

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.
  if ($line =~ m/^(PL_|MallocCfg)/
      || $line eq 'PerlIO_perlio'
      || $line eq 'PerlIO_pending') {
    $vars{$line}++;
  }
  else {
    $fcns{$line}++;
  }
}

if ($debugging_enabled and $isgcc) { $vars{'colors'}++ }
foreach (split /\s+/, $extnames) {
  my($pkgname) = $_;
  $pkgname =~ s/::/__/g;
  $fcns{"boot_$pkgname"}++;
  print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug;
}

# Eventually, we'll check against existing copies here, so we can add new
# symbols to an existing options file in an upwardly-compatible manner.

my $marord = 1;
open(OPTBLD,'>', "${dir}${dbgprefix}perlshr_bld.opt")
  or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n";
if ($isvax) {
  open(MAR, '>', "${dir}perlshr_gbl${marord}.mar")
    or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
  print MAR "\t.title perlshr_gbl$marord\n";
}

unless ($isgcc) {
  print OPTBLD "PSECT_ATTR=LIB\$INITIALIZE,GBL,NOEXE,NOWRT,NOSHR,LONG\n";
}
print OPTBLD "case_sensitive=yes\n" if $care_about_case;
my $count = 0;
foreach my $var (sort (keys %vars)) {
  if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; }
  else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; }
  # This hack brought to you by the lack of a globaldef in gcc.
  if ($isgcc) {
    if ($count++ > 200) {  # max 254 psects/file
      print MAR "\t.end\n";
      close MAR;
      $marord++;
      open(MAR, '>', "${dir}perlshr_gbl${marord}.mar")
        or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
      print MAR "\t.title perlshr_gbl$marord\n";
      $count = 0;
    }
    print MAR "\t.psect ${var},long,pic,ovr,rd,wrt,noexe,noshr\n";
    print MAR "\t${var}::	.blkl 1\n";
  }
}

print MAR "\t.psect \$transfer_vec,pic,rd,nowrt,exe,shr\n" if ($isvax);
foreach my $func (sort keys %fcns) {
  if ($isvax) {
    print MAR "\t.transfer $func\n";
    print MAR "\t.mask $func\n";
    print MAR "\tjmp G\^${func}+2\n";
  }
  else { print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n"; }
}
if ($isvax) {
  print MAR "\t.end\n";
  close MAR;
}

open(OPTATTR, '>', "${dir}perlshr_attr.opt")
  or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
if ($isgcc) {
# TODO -- lost ability to distinguish constant vars from others when
# we switched to using makedef.pl for input.
#  foreach my $var (sort keys %cvars) {
#    print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n";
#  }
  foreach my $var (sort keys %vars) {
    print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
  }
}
else {
  print OPTATTR "! No additional linker directives are needed when using DECC\n";
}
close OPTATTR;

my $incstr = 'PERL,GLOBALS';
my (@symfiles, $drvrname);
if ($isvax) {
  $drvrname = "Compile_shrmars.tmp_".time;
  open (DRVR,'>', $drvrname) or die "$0: Can't write to $drvrname: $!\n";
  print DRVR "\$ Set NoOn\n";  
  print DRVR "\$ Delete/NoLog/NoConfirm $drvrname;\n";
  print DRVR "\$ old_proc_vfy = F\$Environment(\"VERIFY_PROCEDURE\")\n";
  print DRVR "\$ old_img_vfy = F\$Environment(\"VERIFY_IMAGE\")\n";
  print DRVR "\$ MCR $^X -e \"\$ENV{'LIBPERL_RDT'} = (stat('$libperl'))[9]\"\n";
  print DRVR "\$ Set Verify\n";
  print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n";
  do {
    push(@symfiles,"perlshr_gbl$marord");
    print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n";
    print DRVR "\$ Library/Object/Replace/Log $libperl PerlShr_Gbl${marord}$objsuffix\n";
  } while (--$marord); 
  # We had to have a working miniperl to run this program; it's probably the
  # one we just built.  It depended on LibPerl, which will be changed when
  # the PerlShr_Gbl* modules get inserted, so miniperl will be out of date,
  # and so, therefore, will all of its dependents . . .
  # We touch LibPerl here so it'll be back 'in date', and we won't rebuild
  # miniperl etc., and therefore LibPerl, the next time we invoke MM[KS].
  print DRVR "\$ old_proc_vfy = F\$Verify(old_proc_vfy,old_img_vfy)\n";
  print DRVR "\$ MCR $^X -e \"utime 0, \$ENV{'LIBPERL_RDT'}, '$libperl'\"\n";
  close DRVR;
}

# Initial hack to permit building of compatible shareable images for a
# given version of Perl.
if ($ENV{PERLSHR_USE_GSMATCH}) {
  if ($ENV{PERLSHR_USE_GSMATCH} eq 'INCLUDE_COMPILE_OPTIONS') {
    # Build up a major ID. Since on Alpha it can only be 8 bits, we encode
    # the version number in the top 5 bits and use the bottom 3 for build
    # options most likely to cause incompatibilities.  Breaks at Perl 5.32.
    my ($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d\d)/;
    $ver += 0; $sub += 0;
    my $gsmatch = ($ver % 2 == 1) ? "EQUAL" : "LEQUAL"; # Force an equal match for
						  # dev, but be more forgiving
						  # for releases

    $ver <<= 3;
    $ver += 1 if $debugging_enabled;	# If DEBUGGING is set
    $ver += 2 if $use_threads;		# if we're threaded
    $ver += 4 if $use_mymalloc;		# if we're using perl's malloc
    print OPTBLD "GSMATCH=$gsmatch,$ver,$sub\n";
  }
  else {
    my $major = int($] * 1000)                        & 0xFF;  # range 0..255
    my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF;  # range 0..255
    print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n";
  }
  print OPTBLD 'CLUSTER=$$TRANSFER_VECTOR,,',
               map(",$_$objsuffix",@symfiles), "\n" if $isvax;
}
elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); }
# Include object modules and RTLs in options file
# Linker wants /Include and /Library on different lines
print OPTBLD "$libperl/Include=($incstr)\n";
print OPTBLD "$libperl/Library\n";
open(RTLOPT,$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n";
while (<RTLOPT>) { print OPTBLD; }
close RTLOPT;
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__
Commit	Line	Data
a0d0e21e LW	1	# Create global symbol declarations, transfer vector, and
	2	# linker options files for PerlShr.
	3	#
93ea32b8 CB	4	# Processes the output of makedef.pl.
93ea32b8 CB	5	#
a0d0e21e	6	# Input:
93ea32b8	7	# $cc_cmd - compiler command
a0d0e21e	8	# $objsuffix - file type (including '.') used for object files.
748a9306 LW	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
a0d0e21e LW	14	#
a0d0e21e LW	15	# Output:
94ae10c0	16	# PerlShr_Attr.Opt - linker options file which specifies that global vars
a0d0e21e LW	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.
748a9306	20	# PerlShr_Bld.Opt - declares universal symbols for PerlShr.Exe
a0d0e21e LW	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	#
bd3fa61c	36	# Author: Charles Bailey bailey@newman.upenn.edu
a0d0e21e	37
466adc1d	38	use strict;
a0d0e21e LW	39	require 5.000;
a0d0e21e LW	40
466adc1d	41	my $debug = $ENV{'GEN_SHRFLS_DEBUG'};
a5f75d66	42
93ea32b8	43	print "gen_shrfls.pl Rev. 8-Jul-2011\n" if $debug;
71be2cbc	44
a5f75d66 AD	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
93ea32b8	57	my $cc_cmd = shift @ARGV; # no longer used to run the preprocessor
4633a7c4 LW	58
4633a7c4 LW	59	# Someday, we'll have $GetSyI built into perl . . .
466adc1d	60	my $isvax = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .LE. 1024 .AND. F\$GetSyI(\"HW_MODEL\") .GT. 0\)`;
a50752f9	61	chomp $isvax;
4633a7c4 LW	62	print "\$isvax: \\$isvax\\\n" if $debug;
4633a7c4 LW	63
a0d0e21e	64	print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug;
466adc1d	65	my $docc = ($cc_cmd !~ /^~~/);
a0d0e21e LW	66	print "\$docc = $docc\n" if $debug;
a0d0e21e LW	67
0729becf CB	68	my ( $use_threads, $use_mymalloc, $care_about_case, $shorten_symbols,
0729becf CB	69	$debugging_enabled, $hide_mymalloc, $isgcc, $use_perlio, $dir )
466adc1d CB	70	= ( 0, 0, 0, 0, 0, 0, 0, 0 );
466adc1d CB	71
93ea32b8 CB	72	if (-f 'perl.h') { $dir = '[]'; }
	73	elsif (-f '[-]perl.h') { $dir = '[-]'; }
	74	else { die "$0: Can't find perl.h\n"; }
429a5e67	75
93ea32b8 CB	76	# Go see what is enabled in config.sh
	77	my $config = $dir . "config.sh";
	78	open CONFIG, '<', $config;
	79	while(<CONFIG>) {
ac25e0e7	80	$use_threads++ if /usethreads='(define\|yes\|true\|t\|y\|1)'/i;
cbe4ad0c	81	$use_mymalloc++ if /usemymalloc='(define\|yes\|true\|t\|y\|1)'/i;
ac25e0e7	82	$care_about_case++ if /d_vms_case_sensitive_symbols='(define\|yes\|true\|t\|y\|1)'/i;
0729becf	83	$shorten_symbols++ if /d_vms_shorten_long_symbols='(define\|yes\|true\|t\|y\|1)'/i;
ac25e0e7 CL	84	$debugging_enabled++ if /usedebugging_perl='(define\|yes\|true\|t\|y\|1)'/i;
ac25e0e7 CL	85	$hide_mymalloc++ if /embedmymalloc='(define\|yes\|true\|t\|y\|1)'/i;
de4b552e	86	$isgcc++ if /gccversion='[^']/;
ac25e0e7	87	$use_perlio++ if /useperlio='(define\|yes\|true\|t\|y\|1)'/i;
93ea32b8 CB	88	}
93ea32b8 CB	89	close CONFIG;
429a5e67	90
93ea32b8 CB	91	# put quotes back onto defines - they were removed by DCL on the way in
93ea32b8 CB	92	if (my ($prefix,$defines,$suffix) =
a0d0e21e	93	($cc_cmd =~ m#(.)/Define=(.?)([/\s].*)#i)) {
93ea32b8 CB	94	$defines =~ s/^\((.*)\)$/$1/;
	95	$debugging_enabled \|\|= $defines =~ /\bDEBUGGING\b/;
	96	my @defines = split(/,/,$defines);
	97	$cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines))
a0d0e21e	98	. ')' . $suffix;
93ea32b8 CB	99	}
93ea32b8 CB	100	print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug;
de4b552e	101
93ea32b8 CB	102	# check for gcc - if present, we'll need to use MACRO hack to
93ea32b8 CB	103	# define global symbols for shared variables
4633a7c4	104
93ea32b8 CB	105	print "\$isgcc: $isgcc\n" if $debug;
93ea32b8 CB	106	print "\$debugging_enabled: $debugging_enabled\n" if $debug;
a0d0e21e	107
466adc1d	108	my $objsuffix = shift @ARGV;
a0d0e21e	109	print "\$objsuffix: \\$objsuffix\\\n" if $debug;
466adc1d	110	my $dbgprefix = shift @ARGV;
748a9306	111	print "\$dbgprefix: \\$dbgprefix\\\n" if $debug;
466adc1d	112	my $olbsuffix = shift @ARGV;
748a9306	113	print "\$olbsuffix: \\$olbsuffix\\\n" if $debug;
466adc1d CB	114	my $libperl = "${dbgprefix}libperl$olbsuffix";
466adc1d CB	115	my $extnames = shift @ARGV;
748a9306	116	print "\$extnames: \\$extnames\\\n" if $debug;
466adc1d	117	my $rtlopt = shift @ARGV;
748a9306	118	print "\$rtlopt: \\$rtlopt\\\n" if $debug;
a0d0e21e	119
93ea32b8	120	my (%vars, %fcns);
713ca5fa	121
93ea32b8	122	open my $makedefs, '<', $dir . 'makedef.lis' or die "Unable to open makedef.lis: $!";
713ca5fa	123
93ea32b8 CB	124	while (my $line = <$makedefs>) {
93ea32b8 CB	125	chomp $line;
24ad4a07	126	$line = shorten_symbol($line, $care_about_case) if $shorten_symbols;
93ea32b8 CB	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.
f43bd6ba	130	if ($line =~ m/^(PL_\|MallocCfg)/
93ea32b8 CB	131	\|\| $line eq 'PerlIO_perlio'
	132	\|\| $line eq 'PerlIO_pending') {
	133	$vars{$line}++;
09b7f37c CB	134	}
09b7f37c CB	135	else {
93ea32b8	136	$fcns{$line}++;
a0d0e21e	137	}
a0d0e21e	138	}
b9f71c63	139
9ef4b0a6	140	if ($debugging_enabled and $isgcc) { $vars{'colors'}++ }
748a9306 LW	141	foreach (split /\s+/, $extnames) {
	142	my($pkgname) = $_;
	143	$pkgname =~ s/::/__/g;
4633a7c4 LW	144	$fcns{"boot_$pkgname"}++;
4633a7c4 LW	145	print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug;
748a9306	146	}
a0d0e21e LW	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
466adc1d CB	151	my $marord = 1;
466adc1d CB	152	open(OPTBLD,'>', "${dir}${dbgprefix}perlshr_bld.opt")
748a9306	153	or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n";
a0d0e21e	154	if ($isvax) {
466adc1d	155	open(MAR, '>', "${dir}perlshr_gbl${marord}.mar")
a0d0e21e	156	or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
748a9306	157	print MAR "\t.title perlshr_gbl$marord\n";
a0d0e21e	158	}
5e4ba136	159
71be2cbc	160	unless ($isgcc) {
e2367aa8	161	print OPTBLD "PSECT_ATTR=LIB\$INITIALIZE,GBL,NOEXE,NOWRT,NOSHR,LONG\n";
71be2cbc	162	}
b6837a3b	163	print OPTBLD "case_sensitive=yes\n" if $care_about_case;
466adc1d	164	my $count = 0;
93ea32b8	165	foreach my $var (sort (keys %vars)) {
748a9306 LW	166	if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; }
748a9306 LW	167	else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; }
4633a7c4 LW	168	# This hack brought to you by the lack of a globaldef in gcc.
4633a7c4 LW	169	if ($isgcc) {
a0d0e21e LW	170	if ($count++ > 200) { # max 254 psects/file
	171	print MAR "\t.end\n";
	172	close MAR;
	173	$marord++;
466adc1d	174	open(MAR, '>', "${dir}perlshr_gbl${marord}.mar")
a0d0e21e	175	or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
748a9306	176	print MAR "\t.title perlshr_gbl$marord\n";
a0d0e21e LW	177	$count = 0;
a0d0e21e LW	178	}
a0d0e21e LW	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);
466adc1d	185	foreach my $func (sort keys %fcns) {
a0d0e21e LW	186	if ($isvax) {
	187	print MAR "\t.transfer $func\n";
	188	print MAR "\t.mask $func\n";
4633a7c4	189	print MAR "\tjmp G\^${func}+2\n";
a0d0e21e	190	}
748a9306	191	else { print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n"; }
a0d0e21e	192	}
4633a7c4 LW	193	if ($isvax) {
	194	print MAR "\t.end\n";
	195	close MAR;
	196	}
a0d0e21e	197
466adc1d	198	open(OPTATTR, '>', "${dir}perlshr_attr.opt")
4633a7c4	199	or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
ecc0eccd	200	if ($isgcc) {
93ea32b8 CB	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	# }
466adc1d	206	foreach my $var (sort keys %vars) {
71be2cbc	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";
4633a7c4	212	}
a0d0e21e	213	close OPTATTR;
4633a7c4	214
466adc1d CB	215	my $incstr = 'PERL,GLOBALS';
466adc1d CB	216	my (@symfiles, $drvrname);
a0d0e21e	217	if ($isvax) {
a0d0e21e	218	$drvrname = "Compile_shrmars.tmp_".time;
466adc1d	219	open (DRVR,'>', $drvrname) or die "$0: Can't write to $drvrname: $!\n";
a0d0e21e LW	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";
748a9306	224	print DRVR "\$ MCR $^X -e \"\$ENV{'LIBPERL_RDT'} = (stat('$libperl'))[9]\"\n";
a0d0e21e	225	print DRVR "\$ Set Verify\n";
748a9306	226	print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n";
a0d0e21e	227	do {
bbce6d69	228	push(@symfiles,"perlshr_gbl$marord");
a0d0e21e	229	print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n";
748a9306	230	print DRVR "\$ Library/Object/Replace/Log $libperl PerlShr_Gbl${marord}$objsuffix\n";
a0d0e21e	231	} while (--$marord);
748a9306 LW	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].
a0d0e21e	238	print DRVR "\$ old_proc_vfy = F\$Verify(old_proc_vfy,old_img_vfy)\n";
748a9306	239	print DRVR "\$ MCR $^X -e \"utime 0, \$ENV{'LIBPERL_RDT'}, '$libperl'\"\n";
a0d0e21e	240	close DRVR;
a0d0e21e	241	}
748a9306	242
bbce6d69	243	# Initial hack to permit building of compatible shareable images for a
	244	# given version of Perl.
	245	if ($ENV{PERLSHR_USE_GSMATCH}) {
424a8fe9	246	if ($ENV{PERLSHR_USE_GSMATCH} eq 'INCLUDE_COMPILE_OPTIONS') {
0412267b CB	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)/;
e4dfc136	251	$ver += 0; $sub += 0;
0412267b	252	my $gsmatch = ($ver % 2 == 1) ? "EQUAL" : "LEQUAL"; # Force an equal match for
424a8fe9 CB	253	# dev, but be more forgiving
	254	# for releases
	255
0412267b CB	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
424a8fe9 CB	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	}
09b7f37c	267	print OPTBLD 'CLUSTER=$$TRANSFER_VECTOR,,',
0412267b	268	map(",$_$objsuffix",@symfiles), "\n" if $isvax;
bbce6d69	269	}
36477c24	270	elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); }
748a9306 LW	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";
a5f75d66	275	open(RTLOPT,$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n";
748a9306 LW	276	while (<RTLOPT>) { print OPTBLD; }
	277	close RTLOPT;
	278	close OPTBLD;
	279
	280	exec "\$ \@$drvrname" if $isvax;
	281
	282
24ad4a07 CB	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
a0d0e21e	389	__END__
24ad4a07	390