1 # Create global symbol declarations, transfer vector, and
2 # linker options files for PerlShr.
4 # Processes the output of makedef.pl.
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
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
20 # PerlShr_Bld.Opt - declares universal symbols for PerlShr.Exe
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)?
31 # Author: Charles Bailey bailey@newman.upenn.edu
36 my $debug = $ENV{'GEN_SHRFLS_DEBUG'};
38 print "gen_shrfls.pl Rev. 8-Jul-2011\n" if $debug;
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;
46 push(@ARGV,split(/\|/,$_));
49 print "Read input data | ",join(' | ',@ARGV)," |\n" if $debug > 1;
52 my $cc_cmd = shift @ARGV; # no longer used to run the preprocessor
54 print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug;
55 my $docc = ($cc_cmd !~ /^~~/);
56 print "\$docc = $docc\n" if $debug;
58 my ( $use_threads, $use_mymalloc, $care_about_case, $shorten_symbols,
59 $debugging_enabled, $hide_mymalloc, $isgcc, $use_perlio, $dir )
60 = ( 0, 0, 0, 0, 0, 0, 0, 0 );
62 if (-f 'perl.h') { $dir = '[]'; }
63 elsif (-f '[-]perl.h') { $dir = '[-]'; }
64 else { die "$0: Can't find perl.h\n"; }
66 # Go see what is enabled in config.sh
67 my $config = $dir . "config.sh";
68 open CONFIG, '<', $config;
70 $use_threads++ if /usethreads='(define|yes|true|t|y|1)'/i;
71 $use_mymalloc++ if /usemymalloc='(define|yes|true|t|y|1)'/i;
72 $care_about_case++ if /d_vms_case_sensitive_symbols='(define|yes|true|t|y|1)'/i;
73 $shorten_symbols++ if /d_vms_shorten_long_symbols='(define|yes|true|t|y|1)'/i;
74 $debugging_enabled++ if /usedebugging_perl='(define|yes|true|t|y|1)'/i;
75 $hide_mymalloc++ if /embedmymalloc='(define|yes|true|t|y|1)'/i;
76 $isgcc++ if /gccversion='[^']/;
77 $use_perlio++ if /useperlio='(define|yes|true|t|y|1)'/i;
81 # put quotes back onto defines - they were removed by DCL on the way in
82 if (my ($prefix,$defines,$suffix) =
83 ($cc_cmd =~ m#(.*)/Define=(.*?)([/\s].*)#i)) {
84 $defines =~ s/^\((.*)\)$/$1/;
85 $debugging_enabled ||= $defines =~ /\bDEBUGGING\b/;
86 my @defines = split(/,/,$defines);
87 $cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines))
90 print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug;
92 # check for gcc - if present, we'll need to use MACRO hack to
93 # define global symbols for shared variables
95 print "\$isgcc: $isgcc\n" if $debug;
96 print "\$debugging_enabled: $debugging_enabled\n" if $debug;
98 my $objsuffix = shift @ARGV;
99 print "\$objsuffix: \\$objsuffix\\\n" if $debug;
100 my $dbgprefix = shift @ARGV;
101 print "\$dbgprefix: \\$dbgprefix\\\n" if $debug;
102 my $olbsuffix = shift @ARGV;
103 print "\$olbsuffix: \\$olbsuffix\\\n" if $debug;
104 my $libperl = "${dbgprefix}libperl$olbsuffix";
105 my $extnames = shift @ARGV;
106 print "\$extnames: \\$extnames\\\n" if $debug;
107 my $rtlopt = shift @ARGV;
108 print "\$rtlopt: \\$rtlopt\\\n" if $debug;
112 open my $makedefs, '<', $dir . 'makedef.lis' or die "Unable to open makedef.lis: $!";
114 while (my $line = <$makedefs>) {
116 $line = shorten_symbol($line, $care_about_case) if $shorten_symbols;
117 # makedef.pl loses distinction between vars and funcs, so
118 # use the start of the name to guess and add specific
119 # exceptions when we know about them.
120 if ($line =~ m/^(PL_|MallocCfg)/
121 || $line eq 'PerlIO_perlio'
122 || $line eq 'PerlIO_pending') {
130 if ($debugging_enabled and $isgcc) { $vars{'colors'}++ }
131 foreach (split /\s+/, $extnames) {
133 $pkgname =~ s/::/__/g;
134 $fcns{"boot_$pkgname"}++;
135 print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug;
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.
142 open(OPTBLD,'>', "${dir}${dbgprefix}perlshr_bld.opt")
143 or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n";
146 print OPTBLD "PSECT_ATTR=LIB\$INITIALIZE,GBL,NOEXE,NOWRT,NOSHR,LONG\n";
148 print OPTBLD "case_sensitive=yes\n" if $care_about_case;
150 foreach my $var (sort (keys %vars)) {
151 print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n";
154 foreach my $func (sort keys %fcns) {
155 print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n";
158 open(OPTATTR, '>', "${dir}perlshr_attr.opt")
159 or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
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";
166 foreach my $var (sort keys %vars) {
167 print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
171 print OPTATTR "! No additional linker directives are needed when using DECC\n";
175 my $incstr = 'PERL,GLOBALS';
176 my (@symfiles, $drvrname);
178 # Initial hack to permit building of compatible shareable images for a
179 # given version of Perl.
180 if ($ENV{PERLSHR_USE_GSMATCH}) {
181 if ($ENV{PERLSHR_USE_GSMATCH} eq 'INCLUDE_COMPILE_OPTIONS') {
182 # Build up a major ID. Since on Alpha it can only be 8 bits, we encode
183 # the version number in the top 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)/;
186 $ver += 0; $sub += 0;
187 my $gsmatch = ($ver % 2 == 1) ? "EQUAL" : "LEQUAL"; # Force an equal match for
188 # dev, but be more forgiving
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
195 print OPTBLD "GSMATCH=$gsmatch,$ver,$sub\n";
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";
203 elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); }
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";
208 open(RTLOPT,$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n";
209 while (<RTLOPT>) { print OPTBLD; }
214 # Symbol shortening Copyright (c) 2012 Craig A. Berry
216 # Released under the same terms as Perl itself.
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.
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,
273 my $input_string = shift;
274 my $crc = 0xFFFFFFFF;
276 for my $byte (unpack 'C*', $input_string) {
277 $crc = ($crc >> 8) ^ autodin_ii_table->[($crc ^ $byte) & 0xff];
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',
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.
296 $output = base32hex_table->[$input & 0x1f] . $output;
297 $input >>= 5; # position to look at next 5
299 $output .= '$'; # It's DEC, so use '$' not '=' to pad.
305 my $input_symbol = shift;
306 my $as_is_flag = shift;
307 my $symbol = $input_symbol;
309 return $symbol unless length($input_symbol) > 31;
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;
317 return substr($symbol, 0, 23) . $b32;