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 6 bits and use the bottom 2 for build
184 # options most likely to cause incompatibilities. Breaks at Perl 5.64.
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 print OPTBLD "GSMATCH=$gsmatch,$ver,$sub\n";
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";
202 elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); }
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";
207 open(RTLOPT,'<',$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n";
208 while (<RTLOPT>) { print OPTBLD; }
213 # Symbol shortening Copyright (c) 2012 Craig A. Berry
215 # Released under the same terms as Perl itself.
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.
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,
272 my $input_string = shift;
273 my $crc = 0xFFFFFFFF;
275 for my $byte (unpack 'C*', $input_string) {
276 $crc = ($crc >> 8) ^ autodin_ii_table->[($crc ^ $byte) & 0xff];
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',
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.
295 $output = base32hex_table->[$input & 0x1f] . $output;
296 $input >>= 5; # position to look at next 5
298 $output .= '$'; # It's DEC, so use '$' not '=' to pad.
304 my $input_symbol = shift;
305 my $as_is_flag = shift;
306 my $symbol = $input_symbol;
308 return $symbol unless length($input_symbol) > 31;
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;
316 return substr($symbol, 0, 23) . $b32;