regen: B::Op_private and uconfig.h
[perl.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 #
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 #
31 # Author: Charles Bailey  bailey@newman.upenn.edu
32
33 use strict;
34 require 5.000;
35
36 my $debug = $ENV{'GEN_SHRFLS_DEBUG'};
37
38 print "gen_shrfls.pl Rev. 8-Jul-2011\n" if $debug;
39
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
52 my $cc_cmd = shift @ARGV; # no longer used to run the preprocessor
53
54 print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug;
55 my $docc = ($cc_cmd !~ /^~~/);
56 print "\$docc = $docc\n" if $debug;
57
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 );
61
62 if (-f 'perl.h') { $dir = '[]'; }
63 elsif (-f '[-]perl.h') { $dir = '[-]'; }
64 else { die "$0: Can't find perl.h\n"; }
65
66 # Go see what is enabled in config.sh
67 my $config = $dir . "config.sh";
68 open CONFIG, '<', $config;
69 while(<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;
78 }
79 close CONFIG;
80   
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)) 
88               . ')' . $suffix;
89 }
90 print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug;
91
92 # check for gcc - if present, we'll need to use MACRO hack to
93 # define global symbols for shared variables
94
95 print "\$isgcc: $isgcc\n" if $debug;
96 print "\$debugging_enabled: $debugging_enabled\n" if $debug;
97
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;
109
110 my (%vars, %fcns);
111
112 open my $makedefs, '<', $dir . 'makedef.lis' or die "Unable to open makedef.lis: $!";
113
114 while (my $line = <$makedefs>) {
115   chomp $line;
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') {
123     $vars{$line}++;
124   }
125   else {
126     $fcns{$line}++;
127   }
128 }
129
130 if ($debugging_enabled and $isgcc) { $vars{'colors'}++ }
131 foreach (split /\s+/, $extnames) {
132   my($pkgname) = $_;
133   $pkgname =~ s/::/__/g;
134   $fcns{"boot_$pkgname"}++;
135   print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug;
136 }
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
141 my $marord = 1;
142 open(OPTBLD,'>', "${dir}${dbgprefix}perlshr_bld.opt")
143   or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n";
144
145 unless ($isgcc) {
146   print OPTBLD "PSECT_ATTR=LIB\$INITIALIZE,GBL,NOEXE,NOWRT,NOSHR,LONG\n";
147 }
148 print OPTBLD "case_sensitive=yes\n" if $care_about_case;
149 my $count = 0;
150 foreach my $var (sort (keys %vars)) {
151   print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n";
152 }
153
154 foreach my $func (sort keys %fcns) {
155   print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n";
156 }
157
158 open(OPTATTR, '>', "${dir}perlshr_attr.opt")
159   or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
160 if ($isgcc) {
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 #  }
166   foreach my $var (sort keys %vars) {
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";
172 }
173 close OPTATTR;
174
175 my $incstr = 'PERL,GLOBALS';
176 my (@symfiles, $drvrname);
177
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
189                                                   # for releases
190
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
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   }
202 }
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; }
210 close RTLOPT;
211 close OPTBLD;
212
213
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
320 __END__
321