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

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