| 1 | # Create global symbol declarations, transfer vector, and |
| 2 | # linker options files for PerlShr. |
| 3 | # |
| 4 | # Input: |
| 5 | # $cflags - command line qualifiers passed to cc when preprocesing perl.h |
| 6 | # Note: A rather simple-minded attempt is made to restore quotes to |
| 7 | # a /Define clause - use with care. |
| 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 speficies 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@genetics.upenn.edu |
| 37 | |
| 38 | require 5.000; |
| 39 | |
| 40 | $debug = $ENV{'GEN_SHRFLS_DEBUG'}; |
| 41 | |
| 42 | print "gen_shrfls.pl Rev. 14-Dec-1996\n" if $debug; |
| 43 | |
| 44 | if ($ARGV[0] eq '-f') { |
| 45 | open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n"; |
| 46 | print "Input taken from file $ARGV[1]\n" if $debug; |
| 47 | @ARGV = (); |
| 48 | while (<INP>) { |
| 49 | chomp; |
| 50 | push(@ARGV,split(/\|/,$_)); |
| 51 | } |
| 52 | close INP; |
| 53 | print "Read input data | ",join(' | ',@ARGV)," |\n" if $debug > 1; |
| 54 | } |
| 55 | |
| 56 | $cc_cmd = shift @ARGV; |
| 57 | |
| 58 | # Someday, we'll have $GetSyI built into perl . . . |
| 59 | $isvax = `\$ Write Sys\$Output F\$GetSyI(\"HW_MODEL\")` <= 1024; |
| 60 | print "\$isvax: \\$isvax\\\n" if $debug; |
| 61 | |
| 62 | print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug; |
| 63 | $docc = ($cc_cmd !~ /^~~/); |
| 64 | print "\$docc = $docc\n" if $debug; |
| 65 | |
| 66 | if ($docc) { |
| 67 | # put quotes back onto defines - they were removed by DCL on the way in |
| 68 | if (($prefix,$defines,$suffix) = |
| 69 | ($cc_cmd =~ m#(.*)/Define=(.*?)([/\s].*)#i)) { |
| 70 | $defines =~ s/^\((.*)\)$/$1/; |
| 71 | @defines = split(/,/,$defines); |
| 72 | $cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines)) |
| 73 | . ')' . $suffix; |
| 74 | } |
| 75 | print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug; |
| 76 | |
| 77 | # check for gcc - if present, we'll need to use MACRO hack to |
| 78 | # define global symbols for shared variables |
| 79 | $isvaxc = 0; |
| 80 | $isgcc = `$cc_cmd _nla0:/Version` =~ /GNU/ |
| 81 | or 0; # make debug output nice |
| 82 | $isvaxc = (!$isgcc && $isvax && |
| 83 | # Check exit status too, in case message is shut off |
| 84 | (`$cc_cmd /prefix=all _nla0:` =~ /IVQUAL/ || $? == 0x38240)) |
| 85 | or 0; # again, make debug output nice |
| 86 | print "\$isgcc: $isgcc\n" if $debug; |
| 87 | print "\$isvaxc: $isvaxc\n" if $debug; |
| 88 | |
| 89 | if (-f 'perl.h') { $dir = '[]'; } |
| 90 | elsif (-f '[-]perl.h') { $dir = '[-]'; } |
| 91 | else { die "$0: Can't find perl.h\n"; } |
| 92 | } |
| 93 | else { |
| 94 | ($junk,$junk,$cpp_file,$cc_cmd) = split(/~~/,$cc_cmd,4); |
| 95 | $isgcc = $cc_cmd =~ /case_hack/i |
| 96 | or 0; # for nice debug output |
| 97 | $isvaxc = (!$isgcc && $cc_cmd !~ /standard=/i) |
| 98 | or 0; # again, for nice debug output |
| 99 | print "\$isgcc: \\$isgcc\\\n" if $debug; |
| 100 | print "\$isvaxc: \\$isvaxc\\\n" if $debug; |
| 101 | print "Not running cc, preprocesor output in \\$cpp_file\\\n" if $debug; |
| 102 | } |
| 103 | |
| 104 | $objsuffix = shift @ARGV; |
| 105 | print "\$objsuffix: \\$objsuffix\\\n" if $debug; |
| 106 | $dbgprefix = shift @ARGV; |
| 107 | print "\$dbgprefix: \\$dbgprefix\\\n" if $debug; |
| 108 | $olbsuffix = shift @ARGV; |
| 109 | print "\$olbsuffix: \\$olbsuffix\\\n" if $debug; |
| 110 | $libperl = "${dbgprefix}libperl$olbsuffix"; |
| 111 | $extnames = shift @ARGV; |
| 112 | print "\$extnames: \\$extnames\\\n" if $debug; |
| 113 | $rtlopt = shift @ARGV; |
| 114 | print "\$rtlopt: \\$rtlopt\\\n" if $debug; |
| 115 | |
| 116 | # This part gets tricky. VAXC creates global symbols for each of the |
| 117 | # constants in an enum if that enum is ever used as the data type of a |
| 118 | # global[dr]ef. We have to detect enums which are used in this way, so we |
| 119 | # can set up the constants as universal symbols, since anything which |
| 120 | # #includes perl.h will want to resolve these global symbols. |
| 121 | # We're using a weak test here - we basically know that the only enums |
| 122 | # we need to handle now are the big one in opcode.h, and the |
| 123 | # "typedef enum { ... } expectation" in perl.h, so we hard code |
| 124 | # appropriate tests below. Since we can't know in general whether a given |
| 125 | # enum will be used elsewhere in a globaldef, it's hard to decide a |
| 126 | # priori whether its constants need to be treated as global symbols. |
| 127 | sub scan_enum { |
| 128 | my($line) = @_; |
| 129 | |
| 130 | return unless $isvaxc; |
| 131 | |
| 132 | return unless /^\s+(OP|X)/; # we only want opcode and expectation enums |
| 133 | print "\tchecking for enum constant\n" if $debug > 1; |
| 134 | $line =~ s#/\*.+##; |
| 135 | $line =~ s/,?\s*\n?$//; |
| 136 | print "\tfiltered to \\$line\\\n" if $debug > 1; |
| 137 | if ($line =~ /(\w+)$/) { |
| 138 | print "\tconstant name is \\$1\\\n" if $debug > 1; |
| 139 | $enums{$1}++; |
| 140 | } |
| 141 | } |
| 142 | |
| 143 | sub scan_var { |
| 144 | my($line) = @_; |
| 145 | my($const) = $line =~ /^EXTCONST/; |
| 146 | |
| 147 | print "\tchecking for global variable\n" if $debug > 1; |
| 148 | $line =~ s/INIT\(.*\)//; |
| 149 | $line =~ s/\[.*//; |
| 150 | $line =~ s/=.*//; |
| 151 | $line =~ s/\W*;?\s*$//; |
| 152 | print "\tfiltered to \\$line\\\n" if $debug > 1; |
| 153 | if ($line =~ /(\w+)$/) { |
| 154 | print "\tvar name is \\$1\\" . ($const ? ' (const)' : '') . "\n" if $debug > 1; |
| 155 | if ($const) { $cvars{$1}++; } |
| 156 | else { $vars{$1}++; } |
| 157 | } |
| 158 | if ($isvaxc) { |
| 159 | my($type) = $line =~ /^EXT\w*\s+(\w+)/; |
| 160 | print "\tchecking for use of enum (type is \"$type\")\n" if $debug > 2; |
| 161 | if ($type eq 'expectation') { |
| 162 | $used_expectation_enum++; |
| 163 | print "\tsaw global use of enum \"expectation\"\n" if $debug > 1; |
| 164 | } |
| 165 | if ($type eq 'opcode') { |
| 166 | $used_opcode_enum++; |
| 167 | print "\tsaw global use of enum \"opcode\"\n" if $debug > 1; |
| 168 | } |
| 169 | } |
| 170 | } |
| 171 | |
| 172 | sub scan_func { |
| 173 | my($line) = @_; |
| 174 | |
| 175 | print "\tchecking for global routine\n" if $debug > 1; |
| 176 | if ( $line =~ /(\w+)\s+\(/ ) { |
| 177 | print "\troutine name is \\$1\\\n" if $debug > 1; |
| 178 | if ($1 eq 'main' || $1 eq 'perl_init_ext') { |
| 179 | print "\tskipped\n" if $debug > 1; |
| 180 | } |
| 181 | else { $fcns{$1}++ } |
| 182 | } |
| 183 | } |
| 184 | |
| 185 | $used_expectation_enum = $used_opcode_enum = 0; # avoid warnings |
| 186 | if ($docc) { |
| 187 | open(CPP,"${cc_cmd}/NoObj/PreProc=Sys\$Output ${dir}perl.h|") |
| 188 | or die "$0: Can't preprocess ${dir}perl.h: $!\n"; |
| 189 | } |
| 190 | else { |
| 191 | open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n"; |
| 192 | } |
| 193 | LINE: while (<CPP>) { |
| 194 | while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) { |
| 195 | while (/__VMS_PROTOTYPES__/i .. /__VMS_SEPYTOTORP__/i) { |
| 196 | print "vms_proto>> $_" if $debug > 2; |
| 197 | if (/^EXT/) { &scan_var($_); } |
| 198 | else { &scan_func($_); } |
| 199 | last LINE unless $_ = <CPP>; |
| 200 | } |
| 201 | print "vmsish.h>> $_" if $debug > 2; |
| 202 | if (/^EXT/) { &scan_var($_); } |
| 203 | last LINE unless $_ = <CPP>; |
| 204 | } |
| 205 | while (/^#.*opcode\.h/i .. /^#.*perl\.h/i) { |
| 206 | print "opcode.h>> $_" if $debug > 2; |
| 207 | if (/^OP \*\s/) { &scan_func($_); } |
| 208 | if (/^EXT/) { &scan_var($_); } |
| 209 | if (/^\s+OP_/) { &scan_enum($_); } |
| 210 | last LINE unless $_ = <CPP>; |
| 211 | } |
| 212 | while (/^typedef enum/ .. /^\}/) { |
| 213 | print "global enum>> $_" if $debug > 2; |
| 214 | &scan_enum($_); |
| 215 | last LINE unless $_ = <CPP>; |
| 216 | } |
| 217 | while (/^#.*proto\.h/i .. /^#.*perl\.h/i) { |
| 218 | print "proto.h>> $_" if $debug > 2; |
| 219 | if (/^EXT/) { &scan_var($_); } |
| 220 | else { &scan_func($_); } |
| 221 | last LINE unless $_ = <CPP>; |
| 222 | } |
| 223 | print $_ if $debug > 3 && ($debug > 5 || length($_)); |
| 224 | if (/^EXT/) { &scan_var($_); } |
| 225 | } |
| 226 | close CPP; |
| 227 | |
| 228 | |
| 229 | # Kluge to determine whether we need to add EMBED prefix to |
| 230 | # symbols read from local list. vmsreaddirversions() is a VMS- |
| 231 | # specific function whose Perl_ prefix is added in vmsish.h |
| 232 | # if EMBED is #defined. |
| 233 | $embed = exists($fcns{'Perl_vmsreaddirversions'}) ? 'Perl_' : ''; |
| 234 | while (<DATA>) { |
| 235 | next if /^#/; |
| 236 | s/\s+#.*\n//; |
| 237 | next if /^\s*$/; |
| 238 | ($key,$array) = split('=',$_); |
| 239 | $key = "$embed$key"; |
| 240 | print "Adding $key to \%$array list\n" if $debug > 1; |
| 241 | ${$array}{$key}++; |
| 242 | } |
| 243 | foreach (split /\s+/, $extnames) { |
| 244 | my($pkgname) = $_; |
| 245 | $pkgname =~ s/::/__/g; |
| 246 | $fcns{"boot_$pkgname"}++; |
| 247 | print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug; |
| 248 | } |
| 249 | |
| 250 | # If we're using VAXC, fold in the names of the constants for enums |
| 251 | # we've seen as the type of global vars. |
| 252 | if ($isvaxc) { |
| 253 | foreach (keys %enums) { |
| 254 | if (/^OP/) { |
| 255 | $vars{$_}++ if $used_opcode_enum; |
| 256 | next; |
| 257 | } |
| 258 | if (/^X/) { |
| 259 | $vars{$_}++ if $used_expectation_enum; |
| 260 | next; |
| 261 | } |
| 262 | print STDERR "Unrecognized enum constant \"$_\" ignored\n"; |
| 263 | } |
| 264 | } |
| 265 | elsif ($isgcc) { |
| 266 | # gcc creates this as a SHR,WRT psect in globals.c, but we |
| 267 | # don't see it in the perl.h scan, since it's only declared |
| 268 | # if DOINIT is #defined. Bleah. It's cheaper to just add |
| 269 | # it by hand than to add /Define=DOINIT to the preprocessing |
| 270 | # run and wade through all the extra junk. |
| 271 | $vars{'Error'}++; |
| 272 | } |
| 273 | |
| 274 | # Eventually, we'll check against existing copies here, so we can add new |
| 275 | # symbols to an existing options file in an upwardly-compatible manner. |
| 276 | |
| 277 | $marord++; |
| 278 | open(OPTBLD,">${dir}${dbgprefix}perlshr_bld.opt") |
| 279 | or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n"; |
| 280 | if ($isvax) { |
| 281 | open(MAR,">${dir}perlshr_gbl${marord}.mar") |
| 282 | or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n"; |
| 283 | print MAR "\t.title perlshr_gbl$marord\n"; |
| 284 | } |
| 285 | unless ($isgcc) { |
| 286 | print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,PIC,NOEXE,RD,NOWRT,SHR\n"; |
| 287 | print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,PIC,NOEXE,RD,WRT,NOSHR\n"; |
| 288 | } |
| 289 | foreach $var (sort (keys %vars,keys %cvars)) { |
| 290 | if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; } |
| 291 | else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; } |
| 292 | # This hack brought to you by the lack of a globaldef in gcc. |
| 293 | if ($isgcc) { |
| 294 | if ($count++ > 200) { # max 254 psects/file |
| 295 | print MAR "\t.end\n"; |
| 296 | close MAR; |
| 297 | $marord++; |
| 298 | open(MAR,">${dir}perlshr_gbl${marord}.mar") |
| 299 | or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n"; |
| 300 | print MAR "\t.title perlshr_gbl$marord\n"; |
| 301 | $count = 0; |
| 302 | } |
| 303 | print MAR "\t.psect ${var},long,pic,ovr,rd,wrt,noexe,noshr\n"; |
| 304 | print MAR "\t${var}:: .blkl 1\n"; |
| 305 | } |
| 306 | } |
| 307 | |
| 308 | print MAR "\t.psect \$transfer_vec,pic,rd,nowrt,exe,shr\n" if ($isvax); |
| 309 | foreach $func (sort keys %fcns) { |
| 310 | if ($isvax) { |
| 311 | print MAR "\t.transfer $func\n"; |
| 312 | print MAR "\t.mask $func\n"; |
| 313 | print MAR "\tjmp G\^${func}+2\n"; |
| 314 | } |
| 315 | else { print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n"; } |
| 316 | } |
| 317 | if ($isvax) { |
| 318 | print MAR "\t.end\n"; |
| 319 | close MAR; |
| 320 | } |
| 321 | |
| 322 | open(OPTATTR,">${dir}perlshr_attr.opt") |
| 323 | or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n"; |
| 324 | if ($isvaxc) { |
| 325 | print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n"; |
| 326 | } |
| 327 | elsif ($isgcc) { |
| 328 | foreach $var (sort keys %cvars) { |
| 329 | print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n"; |
| 330 | } |
| 331 | foreach $var (sort keys %vars) { |
| 332 | print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; |
| 333 | } |
| 334 | } |
| 335 | else { |
| 336 | print OPTATTR "! No additional linker directives are needed when using DECC\n"; |
| 337 | } |
| 338 | close OPTATTR; |
| 339 | |
| 340 | $incstr = 'perl,globals'; |
| 341 | if ($isvax) { |
| 342 | $drvrname = "Compile_shrmars.tmp_".time; |
| 343 | open (DRVR,">$drvrname") or die "$0: Can't write to $drvrname: $!\n"; |
| 344 | print DRVR "\$ Set NoOn\n"; |
| 345 | print DRVR "\$ Delete/NoLog/NoConfirm $drvrname;\n"; |
| 346 | print DRVR "\$ old_proc_vfy = F\$Environment(\"VERIFY_PROCEDURE\")\n"; |
| 347 | print DRVR "\$ old_img_vfy = F\$Environment(\"VERIFY_IMAGE\")\n"; |
| 348 | print DRVR "\$ MCR $^X -e \"\$ENV{'LIBPERL_RDT'} = (stat('$libperl'))[9]\"\n"; |
| 349 | print DRVR "\$ Set Verify\n"; |
| 350 | print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n"; |
| 351 | do { |
| 352 | push(@symfiles,"perlshr_gbl$marord"); |
| 353 | print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n"; |
| 354 | print DRVR "\$ Library/Object/Replace/Log $libperl PerlShr_Gbl${marord}$objsuffix\n"; |
| 355 | } while (--$marord); |
| 356 | # We had to have a working miniperl to run this program; it's probably the |
| 357 | # one we just built. It depended on LibPerl, which will be changed when |
| 358 | # the PerlShr_Gbl* modules get inserted, so miniperl will be out of date, |
| 359 | # and so, therefore, will all of its dependents . . . |
| 360 | # We touch LibPerl here so it'll be back 'in date', and we won't rebuild |
| 361 | # miniperl etc., and therefore LibPerl, the next time we invoke MM[KS]. |
| 362 | print DRVR "\$ old_proc_vfy = F\$Verify(old_proc_vfy,old_img_vfy)\n"; |
| 363 | print DRVR "\$ MCR $^X -e \"utime 0, \$ENV{'LIBPERL_RDT'}, '$libperl'\"\n"; |
| 364 | close DRVR; |
| 365 | } |
| 366 | |
| 367 | # Initial hack to permit building of compatible shareable images for a |
| 368 | # given version of Perl. |
| 369 | if ($ENV{PERLSHR_USE_GSMATCH}) { |
| 370 | my $major = int($] * 1000) & 0xFF; # range 0..255 |
| 371 | my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF; # range 0..255 |
| 372 | print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n"; |
| 373 | foreach (@symfiles) { |
| 374 | print OPTBLD "CLUSTER=\$\$TRANSFER_VECTOR,,,$_.$objsuffix\n"; |
| 375 | } |
| 376 | } |
| 377 | elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); } |
| 378 | # Include object modules and RTLs in options file |
| 379 | # Linker wants /Include and /Library on different lines |
| 380 | print OPTBLD "$libperl/Include=($incstr)\n"; |
| 381 | print OPTBLD "$libperl/Library\n"; |
| 382 | open(RTLOPT,$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n"; |
| 383 | while (<RTLOPT>) { print OPTBLD; } |
| 384 | close RTLOPT; |
| 385 | close OPTBLD; |
| 386 | |
| 387 | exec "\$ \@$drvrname" if $isvax; |
| 388 | |
| 389 | |
| 390 | __END__ |
| 391 | |
| 392 | # Oddball cases, so we can keep the perl.h scan above simple |
| 393 | rcsid=vars # declared in perl.c |
| 394 | regarglen=vars # declared in regcomp.h |
| 395 | regdummy=vars # declared in regcomp.h |
| 396 | regkind=vars # declared in regcomp.h |
| 397 | simple=vars # declared in regcomp.h |
| 398 | varies=vars # declared in regcomp.h |
| 399 | watchaddr=vars # declared in run.c |
| 400 | watchok=vars # declared in run.c |
| 401 | yychar=vars # generated by byacc in perly.c |
| 402 | yycheck=vars # generated by byacc in perly.c |
| 403 | yydebug=vars # generated by byacc in perly.c |
| 404 | yydefred=vars # generated by byacc in perly.c |
| 405 | yydgoto=vars # generated by byacc in perly.c |
| 406 | yyerrflag=vars # generated by byacc in perly.c |
| 407 | yygindex=vars # generated by byacc in perly.c |
| 408 | yylen=vars # generated by byacc in perly.c |
| 409 | yylhs=vars # generated by byacc in perly.c |
| 410 | yylval=vars # generated by byacc in perly.c |
| 411 | yyname=vars # generated by byacc in perly.c |
| 412 | yynerrs=vars # generated by byacc in perly.c |
| 413 | yyrindex=vars # generated by byacc in perly.c |
| 414 | yyrule=vars # generated by byacc in perly.c |
| 415 | yysindex=vars # generated by byacc in perly.c |
| 416 | yytable=vars # generated by byacc in perly.c |
| 417 | yyval=vars # generated by byacc in perly.c |