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
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.
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)?
36 # Author: Charles Bailey bailey@newman.upenn.edu
41 my $debug = $ENV{'GEN_SHRFLS_DEBUG'};
43 print "gen_shrfls.pl Rev. 8-Jul-2011\n" if $debug;
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;
51 push(@ARGV,split(/\|/,$_));
54 print "Read input data | ",join(' | ',@ARGV)," |\n" if $debug > 1;
57 my $cc_cmd = shift @ARGV; # no longer used to run the preprocessor
59 # Someday, we'll have $GetSyI built into perl . . .
60 my $isvax = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .LE. 1024 .AND. F\$GetSyI(\"HW_MODEL\") .GT. 0\)`;
62 print "\$isvax: \\$isvax\\\n" if $debug;
64 my $isi64 = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .GE. 4096)`;
66 print "\$isi64: \\$isi64\\\n" if $debug;
68 print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug;
69 my $docc = ($cc_cmd !~ /^~~/);
70 print "\$docc = $docc\n" if $debug;
72 my ( $use_threads, $use_mymalloc, $care_about_case, $shorten_symbols,
73 $debugging_enabled, $hide_mymalloc, $isgcc, $use_perlio, $dir )
74 = ( 0, 0, 0, 0, 0, 0, 0, 0 );
76 if (-f 'perl.h') { $dir = '[]'; }
77 elsif (-f '[-]perl.h') { $dir = '[-]'; }
78 else { die "$0: Can't find perl.h\n"; }
80 # Go see what is enabled in config.sh
81 my $config = $dir . "config.sh";
82 open CONFIG, '<', $config;
84 $use_threads++ if /usethreads='(define|yes|true|t|y|1)'/i;
85 $use_mymalloc++ if /usemymalloc='(define|yes|true|t|y|1)'/i;
86 $care_about_case++ if /d_vms_case_sensitive_symbols='(define|yes|true|t|y|1)'/i;
87 $shorten_symbols++ if /d_vms_shorten_long_symbols='(define|yes|true|t|y|1)'/i;
88 $debugging_enabled++ if /usedebugging_perl='(define|yes|true|t|y|1)'/i;
89 $hide_mymalloc++ if /embedmymalloc='(define|yes|true|t|y|1)'/i;
90 $isgcc++ if /gccversion='[^']/;
91 $use_perlio++ if /useperlio='(define|yes|true|t|y|1)'/i;
95 # put quotes back onto defines - they were removed by DCL on the way in
96 if (my ($prefix,$defines,$suffix) =
97 ($cc_cmd =~ m#(.*)/Define=(.*?)([/\s].*)#i)) {
98 $defines =~ s/^\((.*)\)$/$1/;
99 $debugging_enabled ||= $defines =~ /\bDEBUGGING\b/;
100 my @defines = split(/,/,$defines);
101 $cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines))
104 print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug;
106 # check for gcc - if present, we'll need to use MACRO hack to
107 # define global symbols for shared variables
109 print "\$isgcc: $isgcc\n" if $debug;
110 print "\$debugging_enabled: $debugging_enabled\n" if $debug;
112 my $objsuffix = shift @ARGV;
113 print "\$objsuffix: \\$objsuffix\\\n" if $debug;
114 my $dbgprefix = shift @ARGV;
115 print "\$dbgprefix: \\$dbgprefix\\\n" if $debug;
116 my $olbsuffix = shift @ARGV;
117 print "\$olbsuffix: \\$olbsuffix\\\n" if $debug;
118 my $libperl = "${dbgprefix}libperl$olbsuffix";
119 my $extnames = shift @ARGV;
120 print "\$extnames: \\$extnames\\\n" if $debug;
121 my $rtlopt = shift @ARGV;
122 print "\$rtlopt: \\$rtlopt\\\n" if $debug;
126 open my $makedefs, '<', $dir . 'makedef.lis' or die "Unable to open makedef.lis: $!";
128 while (my $line = <$makedefs>) {
130 $line = shorten_symbol($line, $care_about_case) if $shorten_symbols;
131 # makedef.pl loses distinction between vars and funcs, so
132 # use the start of the name to guess and add specific
133 # exceptions when we know about them.
134 if ($line =~ m/^(PL_|MallocCfg)/
135 || $line eq 'PerlIO_perlio'
136 || $line eq 'PerlIO_pending') {
144 if ($debugging_enabled and $isgcc) { $vars{'colors'}++ }
145 foreach (split /\s+/, $extnames) {
147 $pkgname =~ s/::/__/g;
148 $fcns{"boot_$pkgname"}++;
149 print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug;
152 # Eventually, we'll check against existing copies here, so we can add new
153 # symbols to an existing options file in an upwardly-compatible manner.
156 open(OPTBLD,'>', "${dir}${dbgprefix}perlshr_bld.opt")
157 or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n";
159 open(MAR, '>', "${dir}perlshr_gbl${marord}.mar")
160 or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
161 print MAR "\t.title perlshr_gbl$marord\n";
166 print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,NOEXE,RD,NOWRT,SHR\n";
167 print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,NOEXE,RD,WRT,NOSHR\n";
170 print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,PIC,NOEXE,RD,NOWRT,SHR\n";
171 print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,PIC,NOEXE,RD,WRT,NOSHR\n";
173 print OPTBLD "PSECT_ATTR=LIB\$INITIALIZE,GBL,NOEXE,NOWRT,NOSHR,LONG\n";
175 print OPTBLD "case_sensitive=yes\n" if $care_about_case;
177 foreach my $var (sort (keys %vars)) {
178 if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; }
179 else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; }
180 # This hack brought to you by the lack of a globaldef in gcc.
182 if ($count++ > 200) { # max 254 psects/file
183 print MAR "\t.end\n";
186 open(MAR, '>', "${dir}perlshr_gbl${marord}.mar")
187 or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
188 print MAR "\t.title perlshr_gbl$marord\n";
191 print MAR "\t.psect ${var},long,pic,ovr,rd,wrt,noexe,noshr\n";
192 print MAR "\t${var}:: .blkl 1\n";
196 print MAR "\t.psect \$transfer_vec,pic,rd,nowrt,exe,shr\n" if ($isvax);
197 foreach my $func (sort keys %fcns) {
199 print MAR "\t.transfer $func\n";
200 print MAR "\t.mask $func\n";
201 print MAR "\tjmp G\^${func}+2\n";
203 else { print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n"; }
206 print MAR "\t.end\n";
210 open(OPTATTR, '>', "${dir}perlshr_attr.opt")
211 or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
213 # TODO -- lost ability to distinguish constant vars from others when
214 # we switched to using makedef.pl for input.
215 # foreach my $var (sort keys %cvars) {
216 # print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n";
218 foreach my $var (sort keys %vars) {
219 print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
223 print OPTATTR "! No additional linker directives are needed when using DECC\n";
227 my $incstr = 'PERL,GLOBALS';
228 my (@symfiles, $drvrname);
230 $drvrname = "Compile_shrmars.tmp_".time;
231 open (DRVR,'>', $drvrname) or die "$0: Can't write to $drvrname: $!\n";
232 print DRVR "\$ Set NoOn\n";
233 print DRVR "\$ Delete/NoLog/NoConfirm $drvrname;\n";
234 print DRVR "\$ old_proc_vfy = F\$Environment(\"VERIFY_PROCEDURE\")\n";
235 print DRVR "\$ old_img_vfy = F\$Environment(\"VERIFY_IMAGE\")\n";
236 print DRVR "\$ MCR $^X -e \"\$ENV{'LIBPERL_RDT'} = (stat('$libperl'))[9]\"\n";
237 print DRVR "\$ Set Verify\n";
238 print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n";
240 push(@symfiles,"perlshr_gbl$marord");
241 print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n";
242 print DRVR "\$ Library/Object/Replace/Log $libperl PerlShr_Gbl${marord}$objsuffix\n";
244 # We had to have a working miniperl to run this program; it's probably the
245 # one we just built. It depended on LibPerl, which will be changed when
246 # the PerlShr_Gbl* modules get inserted, so miniperl will be out of date,
247 # and so, therefore, will all of its dependents . . .
248 # We touch LibPerl here so it'll be back 'in date', and we won't rebuild
249 # miniperl etc., and therefore LibPerl, the next time we invoke MM[KS].
250 print DRVR "\$ old_proc_vfy = F\$Verify(old_proc_vfy,old_img_vfy)\n";
251 print DRVR "\$ MCR $^X -e \"utime 0, \$ENV{'LIBPERL_RDT'}, '$libperl'\"\n";
255 # Initial hack to permit building of compatible shareable images for a
256 # given version of Perl.
257 if ($ENV{PERLSHR_USE_GSMATCH}) {
258 if ($ENV{PERLSHR_USE_GSMATCH} eq 'INCLUDE_COMPILE_OPTIONS') {
259 # Build up a major ID. Since on Alpha it can only be 8 bits, we encode
260 # the version number in the top 5 bits and use the bottom 3 for build
261 # options most likely to cause incompatibilities. Breaks at Perl 5.32.
262 my ($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d\d)/;
263 $ver += 0; $sub += 0;
264 my $gsmatch = ($ver % 2 == 1) ? "EQUAL" : "LEQUAL"; # Force an equal match for
265 # dev, but be more forgiving
269 $ver += 1 if $debugging_enabled; # If DEBUGGING is set
270 $ver += 2 if $use_threads; # if we're threaded
271 $ver += 4 if $use_mymalloc; # if we're using perl's malloc
272 print OPTBLD "GSMATCH=$gsmatch,$ver,$sub\n";
275 my $major = int($] * 1000) & 0xFF; # range 0..255
276 my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF; # range 0..255
277 print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n";
279 print OPTBLD 'CLUSTER=$$TRANSFER_VECTOR,,',
280 map(",$_$objsuffix",@symfiles), "\n" if $isvax;
282 elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); }
283 # Include object modules and RTLs in options file
284 # Linker wants /Include and /Library on different lines
285 print OPTBLD "$libperl/Include=($incstr)\n";
286 print OPTBLD "$libperl/Library\n";
287 open(RTLOPT,$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n";
288 while (<RTLOPT>) { print OPTBLD; }
292 exec "\$ \@$drvrname" if $isvax;
295 # Symbol shortening Copyright (c) 2012 Craig A. Berry
297 # Released under the same terms as Perl itself.
299 # This code provides shortening of long symbols (> 31 characters) using the
300 # same mechanism as the OpenVMS C compiler. The basic procedure is to compute
301 # an AUTODIN II checksum of the entire symbol, encode the checksum in base32,
302 # and glue together a shortened symbol from the first 23 characters of the
303 # original symbol plus the encoded checksum appended. The output format is
304 # the same used in the name mangler database, stored by default in
305 # [.CXX_REPOSITORY]CXX$DEMANGLER_DB.
308 use constant autodin_ii_table => [
309 0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, 0x706af48f,
310 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, 0xe0d5e91e, 0x97d2d988,
311 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, 0x90bf1d91, 0x1db71064, 0x6ab020f2,
312 0xf3b97148, 0x84be41de, 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7,
313 0x136c9856, 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
314 0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, 0xa2677172,
315 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, 0x35b5a8fa, 0x42b2986c,
316 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, 0x45df5c75, 0xdcd60dcf, 0xabd13d59,
317 0x26d930ac, 0x51de003a, 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423,
318 0xcfba9599, 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924,
319 0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, 0x01db7106,
320 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, 0x9fbfe4a5, 0xe8b8d433,
321 0x7807c9a2, 0x0f00f934, 0x9609a88e, 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d,
322 0x91646c97, 0xe6635c01, 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e,
323 0x6c0695ed, 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950,
324 0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, 0xfbd44c65,
325 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, 0x4adfa541, 0x3dd895d7,
326 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, 0x346ed9fc, 0xad678846, 0xda60b8d0,
327 0x44042d73, 0x33031de5, 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa,
328 0xbe0b1010, 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f,
329 0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, 0x2eb40d81,
330 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, 0x03b6e20c, 0x74b1d29a,
331 0xead54739, 0x9dd277af, 0x04db2615, 0x73dc1683, 0xe3630b12, 0x94643b84,
332 0x0d6d6a3e, 0x7a6a5aa8, 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1,
333 0xf00f9344, 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb,
334 0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, 0x67dd4acc,
335 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, 0xd6d6a3e8, 0xa1d1937e,
336 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, 0xa6bc5767, 0x3fb506dd, 0x48b2364b,
337 0xd80d2bda, 0xaf0a1b4c, 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55,
338 0x316e8eef, 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236,
339 0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, 0xb2bd0b28,
340 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, 0x2cd99e8b, 0x5bdeae1d,
341 0x9b64c2b0, 0xec63f226, 0x756aa39c, 0x026d930a, 0x9c0906a9, 0xeb0e363f,
342 0x72076785, 0x05005713, 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38,
343 0x92d28e9b, 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242,
344 0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, 0x18b74777,
345 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, 0x8f659eff, 0xf862ae69,
346 0x616bffd3, 0x166ccf45, 0xa00ae278, 0xd70dd2ee, 0x4e048354, 0x3903b3c2,
347 0xa7672661, 0xd06016f7, 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc,
348 0x40df0b66, 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9,
349 0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, 0xcdd70693,
350 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, 0x5d681b02, 0x2a6f2b94,
351 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, 0x2d02ef8d,
354 my $input_string = shift;
355 my $crc = 0xFFFFFFFF;
357 for my $byte (unpack 'C*', $input_string) {
358 $crc = ($crc >> 8) ^ autodin_ii_table->[($crc ^ $byte) & 0xff];
366 use constant base32hex_table => [
367 '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
368 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
369 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
373 # Grab lowest 5 bits and look up conversion in table. Lather, rinse,
374 # repeat for a total of 7, 5-bit chunks to accommodate 32 bits of input.
377 $output = base32hex_table->[$input & 0x1f] . $output;
378 $input >>= 5; # position to look at next 5
380 $output .= '$'; # It's DEC, so use '$' not '=' to pad.
386 my $input_symbol = shift;
387 my $as_is_flag = shift;
388 my $symbol = $input_symbol;
390 return $symbol unless length($input_symbol) > 31;
392 $symbol = uc($symbol) unless $as_is_flag;
393 my $crc = crc32($symbol);
394 $crc = ~$crc; # Compiler uses non-inverted form.
395 my $b32 = base32($crc);
396 $b32 = uc($b32) unless $as_is_flag;
398 return substr($symbol, 0, 23) . $b32;