This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
General-purpose symbol shortening for VMS.
[perl5.git] / vms / gen_shrfls.pl
1 # Create global symbol declarations, transfer vector, and
2 # linker options files for PerlShr.
3 #
4 # Processes the output of makedef.pl.
5 #
6 # Input:
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
13 #        must be linked
14 #
15 # Output:
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
19 #        by default.
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.
26 #
27 # To do:
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)?
35 #
36 # Author: Charles Bailey  bailey@newman.upenn.edu
37
38 use strict;
39 require 5.000;
40
41 my $debug = $ENV{'GEN_SHRFLS_DEBUG'};
42
43 print "gen_shrfls.pl Rev. 8-Jul-2011\n" if $debug;
44
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;
48   @ARGV = ();
49   while (<INP>) {
50     chomp;
51     push(@ARGV,split(/\|/,$_));
52   }
53   close INP;
54   print "Read input data | ",join(' | ',@ARGV)," |\n" if $debug > 1;
55 }
56
57 my $cc_cmd = shift @ARGV; # no longer used to run the preprocessor
58
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\)`;
61 chomp $isvax;
62 print "\$isvax: \\$isvax\\\n" if $debug;
63
64 my $isi64 = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .GE. 4096)`;
65 chomp $isi64;
66 print "\$isi64: \\$isi64\\\n" if $debug;
67
68 print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug;
69 my $docc = ($cc_cmd !~ /^~~/);
70 print "\$docc = $docc\n" if $debug;
71
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 );
75
76 if (-f 'perl.h') { $dir = '[]'; }
77 elsif (-f '[-]perl.h') { $dir = '[-]'; }
78 else { die "$0: Can't find perl.h\n"; }
79
80 # Go see what is enabled in config.sh
81 my $config = $dir . "config.sh";
82 open CONFIG, '<', $config;
83 while(<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;
92 }
93 close CONFIG;
94   
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)) 
102               . ')' . $suffix;
103 }
104 print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug;
105
106 # check for gcc - if present, we'll need to use MACRO hack to
107 # define global symbols for shared variables
108
109 print "\$isgcc: $isgcc\n" if $debug;
110 print "\$debugging_enabled: $debugging_enabled\n" if $debug;
111
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;
123
124 my (%vars, %fcns);
125
126 open my $makedefs, '<', $dir . 'makedef.lis' or die "Unable to open makedef.lis: $!";
127
128 while (my $line = <$makedefs>) {
129   chomp $line;
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_/
135       || $line eq 'PerlIO_perlio'
136       || $line eq 'PerlIO_pending') {
137     $vars{$line}++;
138   }
139   else {
140     $fcns{$line}++;
141   }
142 }
143
144 if ($debugging_enabled and $isgcc) { $vars{'colors'}++ }
145 foreach (split /\s+/, $extnames) {
146   my($pkgname) = $_;
147   $pkgname =~ s/::/__/g;
148   $fcns{"boot_$pkgname"}++;
149   print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug;
150 }
151
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.
154
155 my $marord = 1;
156 open(OPTBLD,'>', "${dir}${dbgprefix}perlshr_bld.opt")
157   or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n";
158 if ($isvax) {
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";
162 }
163
164 unless ($isgcc) {
165   if ($isi64) {
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";
168   }
169   else {
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";
172   }
173 }
174 print OPTBLD "case_sensitive=yes\n" if $care_about_case;
175 my $count = 0;
176 foreach my $var (sort (keys %vars)) {
177   if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; }
178   else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; }
179   # This hack brought to you by the lack of a globaldef in gcc.
180   if ($isgcc) {
181     if ($count++ > 200) {  # max 254 psects/file
182       print MAR "\t.end\n";
183       close MAR;
184       $marord++;
185       open(MAR, '>', "${dir}perlshr_gbl${marord}.mar")
186         or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
187       print MAR "\t.title perlshr_gbl$marord\n";
188       $count = 0;
189     }
190     print MAR "\t.psect ${var},long,pic,ovr,rd,wrt,noexe,noshr\n";
191     print MAR "\t${var}::       .blkl 1\n";
192   }
193 }
194
195 print MAR "\t.psect \$transfer_vec,pic,rd,nowrt,exe,shr\n" if ($isvax);
196 foreach my $func (sort keys %fcns) {
197   if ($isvax) {
198     print MAR "\t.transfer $func\n";
199     print MAR "\t.mask $func\n";
200     print MAR "\tjmp G\^${func}+2\n";
201   }
202   else { print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n"; }
203 }
204 if ($isvax) {
205   print MAR "\t.end\n";
206   close MAR;
207 }
208
209 open(OPTATTR, '>', "${dir}perlshr_attr.opt")
210   or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
211 if ($isgcc) {
212 # TODO -- lost ability to distinguish constant vars from others when
213 # we switched to using makedef.pl for input.
214 #  foreach my $var (sort keys %cvars) {
215 #    print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n";
216 #  }
217   foreach my $var (sort keys %vars) {
218     print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
219   }
220 }
221 else {
222   print OPTATTR "! No additional linker directives are needed when using DECC\n";
223 }
224 close OPTATTR;
225
226 my $incstr = 'PERL,GLOBALS';
227 my (@symfiles, $drvrname);
228 if ($isvax) {
229   $drvrname = "Compile_shrmars.tmp_".time;
230   open (DRVR,'>', $drvrname) or die "$0: Can't write to $drvrname: $!\n";
231   print DRVR "\$ Set NoOn\n";  
232   print DRVR "\$ Delete/NoLog/NoConfirm $drvrname;\n";
233   print DRVR "\$ old_proc_vfy = F\$Environment(\"VERIFY_PROCEDURE\")\n";
234   print DRVR "\$ old_img_vfy = F\$Environment(\"VERIFY_IMAGE\")\n";
235   print DRVR "\$ MCR $^X -e \"\$ENV{'LIBPERL_RDT'} = (stat('$libperl'))[9]\"\n";
236   print DRVR "\$ Set Verify\n";
237   print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n";
238   do {
239     push(@symfiles,"perlshr_gbl$marord");
240     print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n";
241     print DRVR "\$ Library/Object/Replace/Log $libperl PerlShr_Gbl${marord}$objsuffix\n";
242   } while (--$marord); 
243   # We had to have a working miniperl to run this program; it's probably the
244   # one we just built.  It depended on LibPerl, which will be changed when
245   # the PerlShr_Gbl* modules get inserted, so miniperl will be out of date,
246   # and so, therefore, will all of its dependents . . .
247   # We touch LibPerl here so it'll be back 'in date', and we won't rebuild
248   # miniperl etc., and therefore LibPerl, the next time we invoke MM[KS].
249   print DRVR "\$ old_proc_vfy = F\$Verify(old_proc_vfy,old_img_vfy)\n";
250   print DRVR "\$ MCR $^X -e \"utime 0, \$ENV{'LIBPERL_RDT'}, '$libperl'\"\n";
251   close DRVR;
252 }
253
254 # Initial hack to permit building of compatible shareable images for a
255 # given version of Perl.
256 if ($ENV{PERLSHR_USE_GSMATCH}) {
257   if ($ENV{PERLSHR_USE_GSMATCH} eq 'INCLUDE_COMPILE_OPTIONS') {
258     # Build up a major ID. Since it can only be 8 bits, we encode the version
259     # number in the top four bits and use the bottom four for build options
260     # that'll cause incompatibilities
261     my ($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d)/;
262     $ver += 0; $sub += 0;
263     my $gsmatch = ($sub >= 50) ? "equal" : "lequal"; # Force an equal match for
264                                                   # dev, but be more forgiving
265                                                   # for releases
266
267     $ver *=16;
268     $ver += 8 if $debugging_enabled;    # If DEBUGGING is set
269     $ver += 4 if $use_threads;          # if we're threaded
270     $ver += 2 if $use_mymalloc;         # if we're using perl's malloc
271     print OPTBLD "GSMATCH=$gsmatch,$ver,$sub\n";
272   }
273   else {
274     my $major = int($] * 1000)                        & 0xFF;  # range 0..255
275     my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF;  # range 0..255
276     print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n";
277   }
278   print OPTBLD 'CLUSTER=$$TRANSFER_VECTOR,,',
279                map(",$_$objsuffix",@symfiles), "\n";
280 }
281 elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); }
282 # Include object modules and RTLs in options file
283 # Linker wants /Include and /Library on different lines
284 print OPTBLD "$libperl/Include=($incstr)\n";
285 print OPTBLD "$libperl/Library\n";
286 open(RTLOPT,$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n";
287 while (<RTLOPT>) { print OPTBLD; }
288 close RTLOPT;
289 close OPTBLD;
290
291 exec "\$ \@$drvrname" if $isvax;
292
293
294 # Symbol shortening Copyright (c) 2012 Craig A. Berry
295 #
296 # Released under the same terms as Perl itself.
297 #
298 # This code provides shortening of long symbols (> 31 characters) using the
299 # same mechanism as the OpenVMS C compiler.  The basic procedure is to compute
300 # an AUTODIN II checksum of the entire symbol, encode the checksum in base32,
301 # and glue together a shortened symbol from the first 23 characters of the
302 # original symbol plus the encoded checksum appended.  The output format is
303 # the same used in the name mangler database, stored by default in
304 # [.CXX_REPOSITORY]CXX$DEMANGLER_DB.
305
306 sub crc32 {
307     use constant autodin_ii_table => [
308         0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, 0x706af48f,
309         0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, 0xe0d5e91e, 0x97d2d988,
310         0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, 0x90bf1d91, 0x1db71064, 0x6ab020f2,
311         0xf3b97148, 0x84be41de, 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7,
312         0x136c9856, 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
313         0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, 0xa2677172,
314         0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, 0x35b5a8fa, 0x42b2986c,
315         0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, 0x45df5c75, 0xdcd60dcf, 0xabd13d59,
316         0x26d930ac, 0x51de003a, 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423,
317         0xcfba9599, 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924,
318         0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, 0x01db7106,
319         0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, 0x9fbfe4a5, 0xe8b8d433,
320         0x7807c9a2, 0x0f00f934, 0x9609a88e, 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d,
321         0x91646c97, 0xe6635c01, 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e,
322         0x6c0695ed, 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950,
323         0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, 0xfbd44c65,
324         0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, 0x4adfa541, 0x3dd895d7,
325         0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, 0x346ed9fc, 0xad678846, 0xda60b8d0,
326         0x44042d73, 0x33031de5, 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa,
327         0xbe0b1010, 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f,
328         0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, 0x2eb40d81,
329         0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, 0x03b6e20c, 0x74b1d29a,
330         0xead54739, 0x9dd277af, 0x04db2615, 0x73dc1683, 0xe3630b12, 0x94643b84,
331         0x0d6d6a3e, 0x7a6a5aa8, 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1,
332         0xf00f9344, 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb,
333         0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, 0x67dd4acc,
334         0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, 0xd6d6a3e8, 0xa1d1937e,
335         0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, 0xa6bc5767, 0x3fb506dd, 0x48b2364b,
336         0xd80d2bda, 0xaf0a1b4c, 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55,
337         0x316e8eef, 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236,
338         0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, 0xb2bd0b28,
339         0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, 0x2cd99e8b, 0x5bdeae1d,
340         0x9b64c2b0, 0xec63f226, 0x756aa39c, 0x026d930a, 0x9c0906a9, 0xeb0e363f,
341         0x72076785, 0x05005713, 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38,
342         0x92d28e9b, 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242,
343         0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, 0x18b74777,
344         0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, 0x8f659eff, 0xf862ae69,
345         0x616bffd3, 0x166ccf45, 0xa00ae278, 0xd70dd2ee, 0x4e048354, 0x3903b3c2,
346         0xa7672661, 0xd06016f7, 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc,
347         0x40df0b66, 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9,
348         0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, 0xcdd70693,
349         0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, 0x5d681b02, 0x2a6f2b94,
350         0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, 0x2d02ef8d,
351     ];
352
353     my $input_string = shift;
354     my $crc = 0xFFFFFFFF;
355
356     for my $byte (unpack 'C*', $input_string) {
357         $crc = ($crc >> 8) ^ autodin_ii_table->[($crc ^ $byte) & 0xff];
358     }
359     return ~$crc;
360 }
361
362 sub base32 {
363     my $input = shift;
364     my $output = '';
365     use constant base32hex_table => [
366         '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
367         'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
368         'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
369         'u', 'v'
370     ];
371
372     # Grab lowest 5 bits and look up conversion in table.  Lather, rinse,
373     # repeat for a total of 7, 5-bit chunks to accommodate 32 bits of input.
374
375     for (0..6) {
376         $output  = base32hex_table->[$input & 0x1f] . $output;
377         $input >>= 5;     # position to look at next 5
378     }
379     $output .= '$';       #  It's DEC, so use '$' not '=' to pad.
380
381     return $output;
382 }
383
384 sub shorten_symbol {
385     my $input_symbol = shift;
386     my $as_is_flag = shift;
387     my $symbol = $input_symbol;
388
389     return $symbol unless length($input_symbol) > 31;
390
391     $symbol = uc($symbol) unless $as_is_flag;
392     my $crc = crc32($symbol);
393     $crc = ~$crc;  # Compiler uses non-inverted form.
394     my $b32 = base32($crc);
395     $b32 = uc($b32) unless $as_is_flag;
396
397     return substr($symbol, 0, 23) . $b32;
398 }
399
400 __END__
401