Commit | Line | Data |
---|---|---|
a0d0e21e LW |
1 | # Create global symbol declarations, transfer vector, and |
2 | # linker options files for PerlShr. | |
3 | # | |
93ea32b8 CB |
4 | # Processes the output of makedef.pl. |
5 | # | |
a0d0e21e | 6 | # Input: |
93ea32b8 | 7 | # $cc_cmd - compiler command |
a0d0e21e | 8 | # $objsuffix - file type (including '.') used for object files. |
748a9306 LW |
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 | |
a0d0e21e LW |
14 | # |
15 | # Output: | |
94ae10c0 | 16 | # PerlShr_Attr.Opt - linker options file which specifies that global vars |
a0d0e21e LW |
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. | |
748a9306 | 20 | # PerlShr_Bld.Opt - declares universal symbols for PerlShr.Exe |
a0d0e21e LW |
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 | # | |
bd3fa61c | 36 | # Author: Charles Bailey bailey@newman.upenn.edu |
a0d0e21e | 37 | |
466adc1d | 38 | use strict; |
a0d0e21e LW |
39 | require 5.000; |
40 | ||
466adc1d | 41 | my $debug = $ENV{'GEN_SHRFLS_DEBUG'}; |
a5f75d66 | 42 | |
93ea32b8 | 43 | print "gen_shrfls.pl Rev. 8-Jul-2011\n" if $debug; |
71be2cbc | 44 | |
a5f75d66 AD |
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 | ||
93ea32b8 | 57 | my $cc_cmd = shift @ARGV; # no longer used to run the preprocessor |
4633a7c4 LW |
58 | |
59 | # Someday, we'll have $GetSyI built into perl . . . | |
466adc1d | 60 | my $isvax = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .LE. 1024 .AND. F\$GetSyI(\"HW_MODEL\") .GT. 0\)`; |
a50752f9 | 61 | chomp $isvax; |
4633a7c4 LW |
62 | print "\$isvax: \\$isvax\\\n" if $debug; |
63 | ||
466adc1d | 64 | my $isi64 = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .GE. 4096)`; |
e8e09534 PP |
65 | chomp $isi64; |
66 | print "\$isi64: \\$isi64\\\n" if $debug; | |
67 | ||
a0d0e21e | 68 | print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug; |
466adc1d | 69 | my $docc = ($cc_cmd !~ /^~~/); |
a0d0e21e LW |
70 | print "\$docc = $docc\n" if $debug; |
71 | ||
0729becf CB |
72 | my ( $use_threads, $use_mymalloc, $care_about_case, $shorten_symbols, |
73 | $debugging_enabled, $hide_mymalloc, $isgcc, $use_perlio, $dir ) | |
466adc1d CB |
74 | = ( 0, 0, 0, 0, 0, 0, 0, 0 ); |
75 | ||
93ea32b8 CB |
76 | if (-f 'perl.h') { $dir = '[]'; } |
77 | elsif (-f '[-]perl.h') { $dir = '[-]'; } | |
78 | else { die "$0: Can't find perl.h\n"; } | |
429a5e67 | 79 | |
93ea32b8 CB |
80 | # Go see what is enabled in config.sh |
81 | my $config = $dir . "config.sh"; | |
82 | open CONFIG, '<', $config; | |
83 | while(<CONFIG>) { | |
ac25e0e7 | 84 | $use_threads++ if /usethreads='(define|yes|true|t|y|1)'/i; |
cbe4ad0c | 85 | $use_mymalloc++ if /usemymalloc='(define|yes|true|t|y|1)'/i; |
ac25e0e7 | 86 | $care_about_case++ if /d_vms_case_sensitive_symbols='(define|yes|true|t|y|1)'/i; |
0729becf | 87 | $shorten_symbols++ if /d_vms_shorten_long_symbols='(define|yes|true|t|y|1)'/i; |
ac25e0e7 CL |
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; | |
de4b552e | 90 | $isgcc++ if /gccversion='[^']/; |
ac25e0e7 | 91 | $use_perlio++ if /useperlio='(define|yes|true|t|y|1)'/i; |
93ea32b8 CB |
92 | } |
93 | close CONFIG; | |
429a5e67 | 94 | |
93ea32b8 CB |
95 | # put quotes back onto defines - they were removed by DCL on the way in |
96 | if (my ($prefix,$defines,$suffix) = | |
a0d0e21e | 97 | ($cc_cmd =~ m#(.*)/Define=(.*?)([/\s].*)#i)) { |
93ea32b8 CB |
98 | $defines =~ s/^\((.*)\)$/$1/; |
99 | $debugging_enabled ||= $defines =~ /\bDEBUGGING\b/; | |
100 | my @defines = split(/,/,$defines); | |
101 | $cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines)) | |
a0d0e21e | 102 | . ')' . $suffix; |
93ea32b8 CB |
103 | } |
104 | print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug; | |
de4b552e | 105 | |
93ea32b8 CB |
106 | # check for gcc - if present, we'll need to use MACRO hack to |
107 | # define global symbols for shared variables | |
4633a7c4 | 108 | |
93ea32b8 CB |
109 | print "\$isgcc: $isgcc\n" if $debug; |
110 | print "\$debugging_enabled: $debugging_enabled\n" if $debug; | |
a0d0e21e | 111 | |
466adc1d | 112 | my $objsuffix = shift @ARGV; |
a0d0e21e | 113 | print "\$objsuffix: \\$objsuffix\\\n" if $debug; |
466adc1d | 114 | my $dbgprefix = shift @ARGV; |
748a9306 | 115 | print "\$dbgprefix: \\$dbgprefix\\\n" if $debug; |
466adc1d | 116 | my $olbsuffix = shift @ARGV; |
748a9306 | 117 | print "\$olbsuffix: \\$olbsuffix\\\n" if $debug; |
466adc1d CB |
118 | my $libperl = "${dbgprefix}libperl$olbsuffix"; |
119 | my $extnames = shift @ARGV; | |
748a9306 | 120 | print "\$extnames: \\$extnames\\\n" if $debug; |
466adc1d | 121 | my $rtlopt = shift @ARGV; |
748a9306 | 122 | print "\$rtlopt: \\$rtlopt\\\n" if $debug; |
a0d0e21e | 123 | |
93ea32b8 | 124 | my (%vars, %fcns); |
713ca5fa | 125 | |
93ea32b8 | 126 | open my $makedefs, '<', $dir . 'makedef.lis' or die "Unable to open makedef.lis: $!"; |
713ca5fa | 127 | |
93ea32b8 CB |
128 | while (my $line = <$makedefs>) { |
129 | chomp $line; | |
130 | # makedef.pl loses distinction between vars and funcs, so | |
131 | # use the start of the name to guess and add specific | |
132 | # exceptions when we know about them. | |
133 | if ($line =~ m/^PL_/ | |
134 | || $line eq 'PerlIO_perlio' | |
135 | || $line eq 'PerlIO_pending') { | |
136 | $vars{$line}++; | |
09b7f37c CB |
137 | } |
138 | else { | |
93ea32b8 | 139 | $fcns{$line}++; |
a0d0e21e | 140 | } |
a0d0e21e | 141 | } |
b9f71c63 | 142 | |
9ef4b0a6 | 143 | if ($debugging_enabled and $isgcc) { $vars{'colors'}++ } |
748a9306 LW |
144 | foreach (split /\s+/, $extnames) { |
145 | my($pkgname) = $_; | |
146 | $pkgname =~ s/::/__/g; | |
4633a7c4 LW |
147 | $fcns{"boot_$pkgname"}++; |
148 | print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug; | |
748a9306 | 149 | } |
a0d0e21e | 150 | |
0729becf CB |
151 | # For symbols over 31 characters, export the shortened name. |
152 | # TODO: Make this general purpose so we can predict the shortened name the | |
153 | # compiler will generate for any symbol over 31 characters in length. The | |
154 | # docs to CC/NAMES=SHORTENED describe the CRC used to shorten the name, but | |
155 | # don't describe its use fully enough to actually mimic what the compiler | |
156 | # does. | |
157 | ||
158 | if ($shorten_symbols) { | |
159 | if (exists $fcns{'Perl_ck_entersub_args_proto_or_list'}) { | |
160 | delete $fcns{'Perl_ck_entersub_args_proto_or_list'}; | |
161 | if ($care_about_case) { | |
162 | $fcns{'Perl_ck_entersub_args_p11c2bjj$'}++; | |
163 | } | |
164 | else { | |
165 | $fcns{'PERL_CK_ENTERSUB_ARGS_P3IAT616$'}++; | |
166 | } | |
167 | } | |
168 | } | |
169 | ||
a0d0e21e LW |
170 | # Eventually, we'll check against existing copies here, so we can add new |
171 | # symbols to an existing options file in an upwardly-compatible manner. | |
172 | ||
466adc1d CB |
173 | my $marord = 1; |
174 | open(OPTBLD,'>', "${dir}${dbgprefix}perlshr_bld.opt") | |
748a9306 | 175 | or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n"; |
a0d0e21e | 176 | if ($isvax) { |
466adc1d | 177 | open(MAR, '>', "${dir}perlshr_gbl${marord}.mar") |
a0d0e21e | 178 | or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n"; |
748a9306 | 179 | print MAR "\t.title perlshr_gbl$marord\n"; |
a0d0e21e | 180 | } |
5e4ba136 | 181 | |
71be2cbc | 182 | unless ($isgcc) { |
e8e09534 PP |
183 | if ($isi64) { |
184 | print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,NOEXE,RD,NOWRT,SHR\n"; | |
185 | print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,NOEXE,RD,WRT,NOSHR\n"; | |
186 | } | |
187 | else { | |
188 | print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,PIC,NOEXE,RD,NOWRT,SHR\n"; | |
189 | print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,PIC,NOEXE,RD,WRT,NOSHR\n"; | |
190 | } | |
71be2cbc | 191 | } |
b6837a3b | 192 | print OPTBLD "case_sensitive=yes\n" if $care_about_case; |
466adc1d | 193 | my $count = 0; |
93ea32b8 | 194 | foreach my $var (sort (keys %vars)) { |
748a9306 LW |
195 | if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; } |
196 | else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; } | |
4633a7c4 LW |
197 | # This hack brought to you by the lack of a globaldef in gcc. |
198 | if ($isgcc) { | |
a0d0e21e LW |
199 | if ($count++ > 200) { # max 254 psects/file |
200 | print MAR "\t.end\n"; | |
201 | close MAR; | |
202 | $marord++; | |
466adc1d | 203 | open(MAR, '>', "${dir}perlshr_gbl${marord}.mar") |
a0d0e21e | 204 | or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n"; |
748a9306 | 205 | print MAR "\t.title perlshr_gbl$marord\n"; |
a0d0e21e LW |
206 | $count = 0; |
207 | } | |
a0d0e21e LW |
208 | print MAR "\t.psect ${var},long,pic,ovr,rd,wrt,noexe,noshr\n"; |
209 | print MAR "\t${var}:: .blkl 1\n"; | |
210 | } | |
211 | } | |
212 | ||
213 | print MAR "\t.psect \$transfer_vec,pic,rd,nowrt,exe,shr\n" if ($isvax); | |
466adc1d | 214 | foreach my $func (sort keys %fcns) { |
a0d0e21e LW |
215 | if ($isvax) { |
216 | print MAR "\t.transfer $func\n"; | |
217 | print MAR "\t.mask $func\n"; | |
4633a7c4 | 218 | print MAR "\tjmp G\^${func}+2\n"; |
a0d0e21e | 219 | } |
748a9306 | 220 | else { print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n"; } |
a0d0e21e | 221 | } |
4633a7c4 LW |
222 | if ($isvax) { |
223 | print MAR "\t.end\n"; | |
224 | close MAR; | |
225 | } | |
a0d0e21e | 226 | |
466adc1d | 227 | open(OPTATTR, '>', "${dir}perlshr_attr.opt") |
4633a7c4 | 228 | or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n"; |
ecc0eccd | 229 | if ($isgcc) { |
93ea32b8 CB |
230 | # TODO -- lost ability to distinguish constant vars from others when |
231 | # we switched to using makedef.pl for input. | |
232 | # foreach my $var (sort keys %cvars) { | |
233 | # print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n"; | |
234 | # } | |
466adc1d | 235 | foreach my $var (sort keys %vars) { |
71be2cbc | 236 | print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; |
237 | } | |
238 | } | |
239 | else { | |
240 | print OPTATTR "! No additional linker directives are needed when using DECC\n"; | |
4633a7c4 | 241 | } |
a0d0e21e | 242 | close OPTATTR; |
4633a7c4 | 243 | |
466adc1d CB |
244 | my $incstr = 'PERL,GLOBALS'; |
245 | my (@symfiles, $drvrname); | |
a0d0e21e | 246 | if ($isvax) { |
a0d0e21e | 247 | $drvrname = "Compile_shrmars.tmp_".time; |
466adc1d | 248 | open (DRVR,'>', $drvrname) or die "$0: Can't write to $drvrname: $!\n"; |
a0d0e21e LW |
249 | print DRVR "\$ Set NoOn\n"; |
250 | print DRVR "\$ Delete/NoLog/NoConfirm $drvrname;\n"; | |
251 | print DRVR "\$ old_proc_vfy = F\$Environment(\"VERIFY_PROCEDURE\")\n"; | |
252 | print DRVR "\$ old_img_vfy = F\$Environment(\"VERIFY_IMAGE\")\n"; | |
748a9306 | 253 | print DRVR "\$ MCR $^X -e \"\$ENV{'LIBPERL_RDT'} = (stat('$libperl'))[9]\"\n"; |
a0d0e21e | 254 | print DRVR "\$ Set Verify\n"; |
748a9306 | 255 | print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n"; |
a0d0e21e | 256 | do { |
bbce6d69 | 257 | push(@symfiles,"perlshr_gbl$marord"); |
a0d0e21e | 258 | print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n"; |
748a9306 | 259 | print DRVR "\$ Library/Object/Replace/Log $libperl PerlShr_Gbl${marord}$objsuffix\n"; |
a0d0e21e | 260 | } while (--$marord); |
748a9306 LW |
261 | # We had to have a working miniperl to run this program; it's probably the |
262 | # one we just built. It depended on LibPerl, which will be changed when | |
263 | # the PerlShr_Gbl* modules get inserted, so miniperl will be out of date, | |
264 | # and so, therefore, will all of its dependents . . . | |
265 | # We touch LibPerl here so it'll be back 'in date', and we won't rebuild | |
266 | # miniperl etc., and therefore LibPerl, the next time we invoke MM[KS]. | |
a0d0e21e | 267 | print DRVR "\$ old_proc_vfy = F\$Verify(old_proc_vfy,old_img_vfy)\n"; |
748a9306 | 268 | print DRVR "\$ MCR $^X -e \"utime 0, \$ENV{'LIBPERL_RDT'}, '$libperl'\"\n"; |
a0d0e21e | 269 | close DRVR; |
a0d0e21e | 270 | } |
748a9306 | 271 | |
bbce6d69 | 272 | # Initial hack to permit building of compatible shareable images for a |
273 | # given version of Perl. | |
274 | if ($ENV{PERLSHR_USE_GSMATCH}) { | |
424a8fe9 CB |
275 | if ($ENV{PERLSHR_USE_GSMATCH} eq 'INCLUDE_COMPILE_OPTIONS') { |
276 | # Build up a major ID. Since it can only be 8 bits, we encode the version | |
277 | # number in the top four bits and use the bottom four for build options | |
278 | # that'll cause incompatibilities | |
466adc1d | 279 | my ($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d)/; |
e4dfc136 | 280 | $ver += 0; $sub += 0; |
466adc1d | 281 | my $gsmatch = ($sub >= 50) ? "equal" : "lequal"; # Force an equal match for |
424a8fe9 CB |
282 | # dev, but be more forgiving |
283 | # for releases | |
284 | ||
285 | $ver *=16; | |
286 | $ver += 8 if $debugging_enabled; # If DEBUGGING is set | |
287 | $ver += 4 if $use_threads; # if we're threaded | |
288 | $ver += 2 if $use_mymalloc; # if we're using perl's malloc | |
289 | print OPTBLD "GSMATCH=$gsmatch,$ver,$sub\n"; | |
290 | } | |
291 | else { | |
292 | my $major = int($] * 1000) & 0xFF; # range 0..255 | |
293 | my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF; # range 0..255 | |
294 | print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n"; | |
295 | } | |
09b7f37c CB |
296 | print OPTBLD 'CLUSTER=$$TRANSFER_VECTOR,,', |
297 | map(",$_$objsuffix",@symfiles), "\n"; | |
bbce6d69 | 298 | } |
36477c24 | 299 | elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); } |
748a9306 LW |
300 | # Include object modules and RTLs in options file |
301 | # Linker wants /Include and /Library on different lines | |
302 | print OPTBLD "$libperl/Include=($incstr)\n"; | |
303 | print OPTBLD "$libperl/Library\n"; | |
a5f75d66 | 304 | open(RTLOPT,$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n"; |
748a9306 LW |
305 | while (<RTLOPT>) { print OPTBLD; } |
306 | close RTLOPT; | |
307 | close OPTBLD; | |
308 | ||
309 | exec "\$ \@$drvrname" if $isvax; | |
310 | ||
311 | ||
a0d0e21e | 312 | __END__ |