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

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