source: trunk/third/perl/vms/gen_shrfls.pl @ 14545

Revision 14545, 12.8 KB checked in by ghudson, 24 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r14544, which included commits to RCS files with non-trunk default branches.
Line 
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@newman.upenn.edu
37
38require 5.000;
39
40$debug = $ENV{'GEN_SHRFLS_DEBUG'};
41
42print "gen_shrfls.pl Rev. 14-Dec-1997\n" if $debug;
43
44if ($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;
60print "\$isvax: \\$isvax\\\n" if $debug;
61
62print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug;
63$docc = ($cc_cmd !~ /^~~/);
64print "\$docc = $docc\n" if $debug;
65
66if ($docc) {
67  if (-f 'perl.h') { $dir = '[]'; }
68  elsif (-f '[-]perl.h') { $dir = '[-]'; }
69  else { die "$0: Can't find perl.h\n"; }
70
71  # Go see if debugging is enabled in config.h
72  $config = $dir . "config.h";
73  open CONFIG, "< $config";
74  while(<CONFIG>) {
75    $debugging_enabled++ if /define\s+DEBUGGING/;
76    $use_mymalloc++ if /define\s+MYMALLOC/;
77    $hide_mymalloc++ if /define\s+EMBEDMYMALLOC/;
78    $use_threads++ if /define\s+USE_THREADS/;
79    $care_about_case++ if /define\s+VMS_WE_ARE_CASE_SENSITIVE/;
80  }
81 
82  # put quotes back onto defines - they were removed by DCL on the way in
83  if (($prefix,$defines,$suffix) =
84         ($cc_cmd =~ m#(.*)/Define=(.*?)([/\s].*)#i)) {
85    $defines =~ s/^\((.*)\)$/$1/;
86    $debugging_enabled ||= $defines =~ /\bDEBUGGING\b/;
87    @defines = split(/,/,$defines);
88    $cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines))
89              . ')' . $suffix;
90  }
91  print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug;
92
93  # check for gcc - if present, we'll need to use MACRO hack to
94  # define global symbols for shared variables
95  $isgcc = `$cc_cmd _nla0:/Version` =~ /GNU/
96           or 0; # make debug output nice
97  print "\$isgcc: $isgcc\n" if $debug;
98  print "\$debugging_enabled: $debugging_enabled\n" if $debug;
99
100}
101else {
102  ($junk,$junk,$cpp_file,$cc_cmd) = split(/~~/,$cc_cmd,4);
103  $isgcc = $cc_cmd =~ /case_hack/i
104           or 0;  # for nice debug output
105  $debugging_enabled = $cc_cmd =~ /\bdebugging\b/i;
106  print "\$isgcc: \\$isgcc\\\n" if $debug;
107  print "\$debugging_enabled: \\$debugging_enabled\\\n" if $debug;
108  print "Not running cc, preprocesor output in \\$cpp_file\\\n" if $debug;
109}
110
111$objsuffix = shift @ARGV;
112print "\$objsuffix: \\$objsuffix\\\n" if $debug;
113$dbgprefix = shift @ARGV;
114print "\$dbgprefix: \\$dbgprefix\\\n" if $debug;
115$olbsuffix = shift @ARGV;
116print "\$olbsuffix: \\$olbsuffix\\\n" if $debug;
117$libperl = "${dbgprefix}libperl$olbsuffix";
118$extnames = shift @ARGV;
119print "\$extnames: \\$extnames\\\n" if $debug;
120$rtlopt = shift @ARGV;
121print "\$rtlopt: \\$rtlopt\\\n" if $debug;
122
123sub scan_var {
124  my($line) = @_;
125  my($const) = $line =~ /^EXTCONST/;
126
127  print "\tchecking for global variable\n" if $debug > 1;
128  $line =~ s/\s*EXT/EXT/;
129  $line =~ s/INIT\s*\(.*\)//;
130  $line =~ s/\[.*//;
131  $line =~ s/=.*//;
132  $line =~ s/\W*;?\s*$//;
133  $line =~ s/\W*\)\s*\(.*$//; # closing paren for args stripped in previous stmt
134  print "\tfiltered to \\$line\\\n" if $debug > 1;
135  if ($line =~ /(\w+)$/) {
136    print "\tvar name is \\$1\\" . ($const ? ' (const)' : '') . "\n" if $debug > 1;
137   if ($const) { $cvars{$1}++; }
138   else        { $vars{$1}++;  }
139  }
140}
141
142sub scan_func {
143  my($line) = @_;
144
145  print "\tchecking for global routine\n" if $debug > 1;
146  if ( $line =~ /(\w+)\s*\(/ ) {
147    print "\troutine name is \\$1\\\n" if $debug > 1;
148    if ($1 eq 'main' || $1 eq 'perl_init_ext') {
149      print "\tskipped\n" if $debug > 1;
150    }
151    else { $fcns{$1}++ }
152  }
153}
154
155# Go add some right up front if we need 'em
156if ($use_mymalloc) {
157  $fcns{'Perl_malloc'}++;
158  $fcns{'Perl_calloc'}++;
159  $fcns{'Perl_realloc'}++;
160  $fcns{'Perl_mfree'}++;
161}
162
163$used_expectation_enum = $used_opcode_enum = 0; # avoid warnings
164if ($docc) {
165  open(CPP,"${cc_cmd}/NoObj/PreProc=Sys\$Output ${dir}perl.h|")
166    or die "$0: Can't preprocess ${dir}perl.h: $!\n";
167}
168else {
169  open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n";
170}
171%checkh = map { $_,1 } qw( thread bytecode byterun proto );
172$ckfunc = 0;
173LINE: while (<CPP>) {
174  while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) {
175    while (/__VMS_PROTOTYPES__/i .. /__VMS_SEPYTOTORP__/i) {
176      print "vms_proto>> $_" if $debug > 2;
177      if (/^\s*EXT/) { &scan_var($_);  }
178      else        { &scan_func($_); }
179      last LINE unless defined($_ = <CPP>);
180    }
181    print "vmsish.h>> $_" if $debug > 2;
182    if (/^\s*EXT/) { &scan_var($_); }
183    last LINE unless defined($_ = <CPP>);
184  }   
185  while (/^#.*opcode\.h/i .. /^#.*perl\.h/i) {
186    print "opcode.h>> $_" if $debug > 2;
187    if (/^OP \*\s/) { &scan_func($_); }
188    if (/^\s*EXT/) { &scan_var($_); }
189    last LINE unless defined($_ = <CPP>);
190  }
191  # Check for transition to new header file
192  if (/^# \d+ "(\S+)"/) {
193    my $spec = $1;
194    # Pull name from library module or header filespec
195    $spec =~ /^(\w+)$/ or $spec =~ /(\w+)\.h/i;
196    my $name = lc $1;
197    $ckfunc = exists $checkh{$name} ? 1 : 0;
198    $scanname = $name if $ckfunc;
199    print "Header file transition: ckfunc = $ckfunc for $name.h\n" if $debug > 1;
200  }
201  if ($ckfunc) {
202    print "$scanname>> $_" if $debug > 2;
203    if (/\s*^EXT/) { &scan_var($_);  }
204    else           { &scan_func($_); }
205  }
206  else {
207    print $_ if $debug > 3 && ($debug > 5 || length($_));
208    if (/^\s*EXT/) { &scan_var($_); }
209  }
210}
211close CPP;
212
213while (<DATA>) {
214  next if /^#/;
215  s/\s+#.*\n//;
216  next if /^\s*$/;
217  ($key,$array) = split('=',$_);
218  if ($array eq 'vars') { $key = "PL_$key";   }
219  else                  { $key = "Perl_$key"; }
220  print "Adding $key to \%$array list\n" if $debug > 1;
221  ${$array}{$key}++;
222}
223if ($debugging_enabled and $isgcc) { $vars{'colors'}++ }
224foreach (split /\s+/, $extnames) {
225  my($pkgname) = $_;
226  $pkgname =~ s/::/__/g;
227  $fcns{"boot_$pkgname"}++;
228  print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug;
229}
230
231# Eventually, we'll check against existing copies here, so we can add new
232# symbols to an existing options file in an upwardly-compatible manner.
233
234$marord++;
235open(OPTBLD,">${dir}${dbgprefix}perlshr_bld.opt")
236  or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n";
237if ($isvax) {
238  open(MAR,">${dir}perlshr_gbl${marord}.mar")
239    or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
240  print MAR "\t.title perlshr_gbl$marord\n";
241}
242
243unless ($isgcc) {
244  print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,PIC,NOEXE,RD,NOWRT,SHR\n";
245  print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,PIC,NOEXE,RD,WRT,NOSHR\n";
246}
247print OPTBLD "case_sensitive=yes\n" if $care_about_case;
248foreach $var (sort (keys %vars,keys %cvars)) {
249  if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; }
250  else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; }
251  # This hack brought to you by the lack of a globaldef in gcc.
252  if ($isgcc) {
253    if ($count++ > 200) {  # max 254 psects/file
254      print MAR "\t.end\n";
255      close MAR;
256      $marord++;
257      open(MAR,">${dir}perlshr_gbl${marord}.mar")
258        or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
259      print MAR "\t.title perlshr_gbl$marord\n";
260      $count = 0;
261    }
262    print MAR "\t.psect ${var},long,pic,ovr,rd,wrt,noexe,noshr\n";
263    print MAR "\t${var}::       .blkl 1\n";
264  }
265}
266
267print MAR "\t.psect \$transfer_vec,pic,rd,nowrt,exe,shr\n" if ($isvax);
268foreach $func (sort keys %fcns) {
269  if ($isvax) {
270    print MAR "\t.transfer $func\n";
271    print MAR "\t.mask $func\n";
272    print MAR "\tjmp G\^${func}+2\n";
273  }
274  else { print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n"; }
275}
276if ($isvax) {
277  print MAR "\t.end\n";
278  close MAR;
279}
280
281open(OPTATTR,">${dir}perlshr_attr.opt")
282  or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
283if ($isgcc) {
284  foreach $var (sort keys %cvars) {
285    print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n";
286  }
287  foreach $var (sort keys %vars) {
288    print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
289  }
290}
291else {
292  print OPTATTR "! No additional linker directives are needed when using DECC\n";
293}
294close OPTATTR;
295
296$incstr = 'PERL,GLOBALS';
297if ($isvax) {
298  $drvrname = "Compile_shrmars.tmp_".time;
299  open (DRVR,">$drvrname") or die "$0: Can't write to $drvrname: $!\n";
300  print DRVR "\$ Set NoOn\n"; 
301  print DRVR "\$ Delete/NoLog/NoConfirm $drvrname;\n";
302  print DRVR "\$ old_proc_vfy = F\$Environment(\"VERIFY_PROCEDURE\")\n";
303  print DRVR "\$ old_img_vfy = F\$Environment(\"VERIFY_IMAGE\")\n";
304  print DRVR "\$ MCR $^X -e \"\$ENV{'LIBPERL_RDT'} = (stat('$libperl'))[9]\"\n";
305  print DRVR "\$ Set Verify\n";
306  print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n";
307  do {
308    push(@symfiles,"perlshr_gbl$marord");
309    print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n";
310    print DRVR "\$ Library/Object/Replace/Log $libperl PerlShr_Gbl${marord}$objsuffix\n";
311  } while (--$marord);
312  # We had to have a working miniperl to run this program; it's probably the
313  # one we just built.  It depended on LibPerl, which will be changed when
314  # the PerlShr_Gbl* modules get inserted, so miniperl will be out of date,
315  # and so, therefore, will all of its dependents . . .
316  # We touch LibPerl here so it'll be back 'in date', and we won't rebuild
317  # miniperl etc., and therefore LibPerl, the next time we invoke MM[KS].
318  print DRVR "\$ old_proc_vfy = F\$Verify(old_proc_vfy,old_img_vfy)\n";
319  print DRVR "\$ MCR $^X -e \"utime 0, \$ENV{'LIBPERL_RDT'}, '$libperl'\"\n";
320  close DRVR;
321}
322
323# Initial hack to permit building of compatible shareable images for a
324# given version of Perl.
325if ($ENV{PERLSHR_USE_GSMATCH}) {
326  if ($ENV{PERLSHR_USE_GSMATCH} eq 'INCLUDE_COMPILE_OPTIONS') {
327    # Build up a major ID. Since it can only be 8 bits, we encode the version
328    # number in the top four bits and use the bottom four for build options
329    # that'll cause incompatibilities
330    ($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d)/;
331    $gsmatch = ($sub >= 50) ? "equal" : "lequal"; # Force an equal match for
332                                                  # dev, but be more forgiving
333                                                  # for releases
334
335    $ver *=16;
336    $ver += 8 if $debugging_enabled;    # If DEBUGGING is set
337    $ver += 4 if $use_threads;          # if we're threaded
338    $ver += 2 if $use_mymalloc;         # if we're using perl's malloc
339    print OPTBLD "GSMATCH=$gsmatch,$ver,$sub\n";
340  }
341  else {
342    my $major = int($] * 1000)                        & 0xFF;  # range 0..255
343    my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF;  # range 0..255
344    print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n";
345  }
346  print OPTBLD 'CLUSTER=$$TRANSFER_VECTOR,,',
347               map(",$_$objsuffix",@symfiles), "\n";
348}
349elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); }
350# Include object modules and RTLs in options file
351# Linker wants /Include and /Library on different lines
352print OPTBLD "$libperl/Include=($incstr)\n";
353print OPTBLD "$libperl/Library\n";
354open(RTLOPT,$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n";
355while (<RTLOPT>) { print OPTBLD; }
356close RTLOPT;
357close OPTBLD;
358
359exec "\$ \@$drvrname" if $isvax;
360
361
362__END__
363
364# Oddball cases, so we can keep the perl.h scan above simple
365regkind=vars    # declared in regcomp.h
366simple=vars     # declared in regcomp.h
367varies=vars     # declared in regcomp.h
Note: See TracBrowser for help on using the repository browser.