[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
#
# 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

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";

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)) {
  print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n";
}

foreach my $func (sort keys %fcns) {
  print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n";
}

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);

# 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 6 bits and use the bottom 2 for build
    # options most likely to cause incompatibilities.  Breaks at Perl 5.64.
    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 <<= 2;
    $ver += 1 if $debugging_enabled;	# If DEBUGGING is set
    $ver += 2 if $use_threads;		# if we're threaded
    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";
  }
}
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;


# 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	#
	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	#
bd3fa61c	31	# Author: Charles Bailey bailey@newman.upenn.edu
a0d0e21e	32
466adc1d	33	use strict;
a0d0e21e LW	34	require 5.000;
a0d0e21e LW	35
466adc1d	36	my $debug = $ENV{'GEN_SHRFLS_DEBUG'};
a5f75d66	37
93ea32b8	38	print "gen_shrfls.pl Rev. 8-Jul-2011\n" if $debug;
71be2cbc	39
a5f75d66	40	if ($ARGV[0] eq '-f') {
1ae6ead9	41	open(INP,'<',$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n";
a5f75d66 AD	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
93ea32b8	52	my $cc_cmd = shift @ARGV; # no longer used to run the preprocessor
4633a7c4	53
a0d0e21e	54	print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug;
466adc1d	55	my $docc = ($cc_cmd !~ /^~~/);
a0d0e21e LW	56	print "\$docc = $docc\n" if $debug;
a0d0e21e LW	57
0729becf CB	58	my ( $use_threads, $use_mymalloc, $care_about_case, $shorten_symbols,
0729becf CB	59	$debugging_enabled, $hide_mymalloc, $isgcc, $use_perlio, $dir )
466adc1d CB	60	= ( 0, 0, 0, 0, 0, 0, 0, 0 );
466adc1d CB	61
93ea32b8 CB	62	if (-f 'perl.h') { $dir = '[]'; }
	63	elsif (-f '[-]perl.h') { $dir = '[-]'; }
	64	else { die "$0: Can't find perl.h\n"; }
429a5e67	65
93ea32b8 CB	66	# Go see what is enabled in config.sh
	67	my $config = $dir . "config.sh";
	68	open CONFIG, '<', $config;
	69	while(<CONFIG>) {
ac25e0e7	70	$use_threads++ if /usethreads='(define\|yes\|true\|t\|y\|1)'/i;
cbe4ad0c	71	$use_mymalloc++ if /usemymalloc='(define\|yes\|true\|t\|y\|1)'/i;
ac25e0e7	72	$care_about_case++ if /d_vms_case_sensitive_symbols='(define\|yes\|true\|t\|y\|1)'/i;
0729becf	73	$shorten_symbols++ if /d_vms_shorten_long_symbols='(define\|yes\|true\|t\|y\|1)'/i;
ac25e0e7 CL	74	$debugging_enabled++ if /usedebugging_perl='(define\|yes\|true\|t\|y\|1)'/i;
ac25e0e7 CL	75	$hide_mymalloc++ if /embedmymalloc='(define\|yes\|true\|t\|y\|1)'/i;
de4b552e	76	$isgcc++ if /gccversion='[^']/;
ac25e0e7	77	$use_perlio++ if /useperlio='(define\|yes\|true\|t\|y\|1)'/i;
93ea32b8 CB	78	}
93ea32b8 CB	79	close CONFIG;
429a5e67	80
93ea32b8 CB	81	# put quotes back onto defines - they were removed by DCL on the way in
93ea32b8 CB	82	if (my ($prefix,$defines,$suffix) =
a0d0e21e	83	($cc_cmd =~ m#(.)/Define=(.?)([/\s].*)#i)) {
93ea32b8 CB	84	$defines =~ s/^\((.*)\)$/$1/;
	85	$debugging_enabled \|\|= $defines =~ /\bDEBUGGING\b/;
	86	my @defines = split(/,/,$defines);
	87	$cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines))
a0d0e21e	88	. ')' . $suffix;
93ea32b8 CB	89	}
93ea32b8 CB	90	print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug;
de4b552e	91
93ea32b8 CB	92	# check for gcc - if present, we'll need to use MACRO hack to
93ea32b8 CB	93	# define global symbols for shared variables
4633a7c4	94
93ea32b8 CB	95	print "\$isgcc: $isgcc\n" if $debug;
93ea32b8 CB	96	print "\$debugging_enabled: $debugging_enabled\n" if $debug;
a0d0e21e	97
466adc1d	98	my $objsuffix = shift @ARGV;
a0d0e21e	99	print "\$objsuffix: \\$objsuffix\\\n" if $debug;
466adc1d	100	my $dbgprefix = shift @ARGV;
748a9306	101	print "\$dbgprefix: \\$dbgprefix\\\n" if $debug;
466adc1d	102	my $olbsuffix = shift @ARGV;
748a9306	103	print "\$olbsuffix: \\$olbsuffix\\\n" if $debug;
466adc1d CB	104	my $libperl = "${dbgprefix}libperl$olbsuffix";
466adc1d CB	105	my $extnames = shift @ARGV;
748a9306	106	print "\$extnames: \\$extnames\\\n" if $debug;
466adc1d	107	my $rtlopt = shift @ARGV;
748a9306	108	print "\$rtlopt: \\$rtlopt\\\n" if $debug;
a0d0e21e	109
93ea32b8	110	my (%vars, %fcns);
713ca5fa	111
93ea32b8	112	open my $makedefs, '<', $dir . 'makedef.lis' or die "Unable to open makedef.lis: $!";
713ca5fa	113
93ea32b8 CB	114	while (my $line = <$makedefs>) {
93ea32b8 CB	115	chomp $line;
24ad4a07	116	$line = shorten_symbol($line, $care_about_case) if $shorten_symbols;
93ea32b8 CB	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.
f43bd6ba	120	if ($line =~ m/^(PL_\|MallocCfg)/
93ea32b8 CB	121	\|\| $line eq 'PerlIO_perlio'
	122	\|\| $line eq 'PerlIO_pending') {
	123	$vars{$line}++;
09b7f37c CB	124	}
09b7f37c CB	125	else {
93ea32b8	126	$fcns{$line}++;
a0d0e21e	127	}
a0d0e21e	128	}
b9f71c63	129
9ef4b0a6	130	if ($debugging_enabled and $isgcc) { $vars{'colors'}++ }
748a9306 LW	131	foreach (split /\s+/, $extnames) {
	132	my($pkgname) = $_;
	133	$pkgname =~ s/::/__/g;
4633a7c4 LW	134	$fcns{"boot_$pkgname"}++;
4633a7c4 LW	135	print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug;
748a9306	136	}
a0d0e21e LW	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
466adc1d CB	141	my $marord = 1;
466adc1d CB	142	open(OPTBLD,'>', "${dir}${dbgprefix}perlshr_bld.opt")
748a9306	143	or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n";
5e4ba136	144
71be2cbc	145	unless ($isgcc) {
e2367aa8	146	print OPTBLD "PSECT_ATTR=LIB\$INITIALIZE,GBL,NOEXE,NOWRT,NOSHR,LONG\n";
71be2cbc	147	}
b6837a3b	148	print OPTBLD "case_sensitive=yes\n" if $care_about_case;
466adc1d	149	my $count = 0;
93ea32b8	150	foreach my $var (sort (keys %vars)) {
054a3baf	151	print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n";
a0d0e21e LW	152	}
a0d0e21e LW	153
466adc1d	154	foreach my $func (sort keys %fcns) {
054a3baf	155	print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n";
4633a7c4	156	}
a0d0e21e	157
466adc1d	158	open(OPTATTR, '>', "${dir}perlshr_attr.opt")
4633a7c4	159	or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
ecc0eccd	160	if ($isgcc) {
93ea32b8 CB	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	# }
466adc1d	166	foreach my $var (sort keys %vars) {
71be2cbc	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";
4633a7c4	172	}
a0d0e21e	173	close OPTATTR;
4633a7c4	174
d15ced93	175	my $incstr = 'perl,globals';
466adc1d	176	my (@symfiles, $drvrname);
748a9306	177
bbce6d69	178	# Initial hack to permit building of compatible shareable images for a
	179	# given version of Perl.
	180	if ($ENV{PERLSHR_USE_GSMATCH}) {
424a8fe9	181	if ($ENV{PERLSHR_USE_GSMATCH} eq 'INCLUDE_COMPILE_OPTIONS') {
0412267b	182	# Build up a major ID. Since on Alpha it can only be 8 bits, we encode
8b403984 CB	183	# the version number in the top 6 bits and use the bottom 2 for build
8b403984 CB	184	# options most likely to cause incompatibilities. Breaks at Perl 5.64.
0412267b	185	my ($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d\d)/;
e4dfc136	186	$ver += 0; $sub += 0;
0412267b	187	my $gsmatch = ($ver % 2 == 1) ? "EQUAL" : "LEQUAL"; # Force an equal match for
424a8fe9 CB	188	# dev, but be more forgiving
	189	# for releases
	190
8b403984	191	$ver <<= 2;
0412267b CB	192	$ver += 1 if $debugging_enabled; # If DEBUGGING is set
0412267b CB	193	$ver += 2 if $use_threads; # if we're threaded
424a8fe9 CB	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	}
bbce6d69	201	}
36477c24	202	elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); }
748a9306 LW	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";
1ae6ead9	207	open(RTLOPT,'<',$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n";
748a9306 LW	208	while (<RTLOPT>) { print OPTBLD; }
	209	close RTLOPT;
	210	close OPTBLD;
	211
748a9306	212
24ad4a07 CB	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
a0d0e21e	319	__END__
24ad4a07	320