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