X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fgen_shrfls.pl;h=7ba40fd5afc5ad8b67ba4153fb05640cb7b4df09;hb=efa50c51e3301a2ca8be765fedfdae78eff1615b;hp=9d5748d499051d58288ff85b20e6c0a1ada84749;hpb=09b7f37c58c6da6f4965b846b64eab7d9a205663;p=p5sagit%2Fp5-mst-13.2.git diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl index 9d5748d..7ba40fd 100644 --- a/vms/gen_shrfls.pl +++ b/vms/gen_shrfls.pl @@ -33,13 +33,13 @@ # library has everything old one did # (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)? # -# Author: Charles Bailey bailey@genetics.upenn.edu +# Author: Charles Bailey bailey@newman.upenn.edu require 5.000; $debug = $ENV{'GEN_SHRFLS_DEBUG'}; -print "gen_shrfls.pl Rev. 14-Dec-1997\n" if $debug; +print "gen_shrfls.pl Rev. 18-Dec-2003\n" if $debug; if ($ARGV[0] eq '-f') { open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n"; @@ -56,19 +56,45 @@ if ($ARGV[0] eq '-f') { $cc_cmd = shift @ARGV; # Someday, we'll have $GetSyI built into perl . . . -$isvax = `\$ Write Sys\$Output F\$GetSyI(\"HW_MODEL\")` <= 1024; +$isvax = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .LE. 1024 .AND. F\$GetSyI(\"HW_MODEL\") .GT. 0\)`; +chomp $isvax; print "\$isvax: \\$isvax\\\n" if $debug; +$isi64 = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .GE. 4096)`; +chomp $isi64; +print "\$isi64: \\$isi64\\\n" if $debug; + print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug; $docc = ($cc_cmd !~ /^~~/); print "\$docc = $docc\n" if $debug; if ($docc) { + if (-f 'perl.h') { $dir = '[]'; } + elsif (-f '[-]perl.h') { $dir = '[-]'; } + else { die "$0: Can't find perl.h\n"; } + + $use_threads = $use_mymalloc = $case_about_case = $debugging_enabled = 0; + $hide_mymalloc = $isgcc = $use_perlio = 0; + + # Go see what is enabled in config.sh + $config = $dir . "config.sh"; + open CONFIG, "< $config"; + while() { + $use_threads++ if /usethreads='(define|yes|true|t|y|1)'/i; + $use_mymalloc++ if /usemymalloc='(define|yes|true|t|y|1)'/i; + $care_about_case++ if /d_vms_case_sensitive_symbols='(define|yes|true|t|y|1)'/i; + $debugging_enabled++ if /usedebugging_perl='(define|yes|true|t|y|1)'/i; + $hide_mymalloc++ if /embedmymalloc='(define|yes|true|t|y|1)'/i; + $isgcc++ if /gccversion='[^']/; + $use_perlio++ if /useperlio='(define|yes|true|t|y|1)'/i; + } + close CONFIG; + # put quotes back onto defines - they were removed by DCL on the way in if (($prefix,$defines,$suffix) = ($cc_cmd =~ m#(.*)/Define=(.*?)([/\s].*)#i)) { $defines =~ s/^\((.*)\)$/$1/; - $debugging_enabled = $defines =~ /\bDEBUGGING\b/; + $debugging_enabled ||= $defines =~ /\bDEBUGGING\b/; @defines = split(/,/,$defines); $cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines)) . ')' . $suffix; @@ -77,30 +103,17 @@ if ($docc) { # check for gcc - if present, we'll need to use MACRO hack to # define global symbols for shared variables - $isvaxc = 0; - $isgcc = `$cc_cmd _nla0:/Version` =~ /GNU/ - or 0; # make debug output nice - $isvaxc = (!$isgcc && $isvax && - # Check exit status too, in case message is shut off - (`$cc_cmd /prefix=all _nla0:` =~ /IVQUAL/ || $? == 0x38240)) - or 0; # again, make debug output nice + print "\$isgcc: $isgcc\n" if $debug; - print "\$isvaxc: $isvaxc\n" if $debug; print "\$debugging_enabled: $debugging_enabled\n" if $debug; - if (-f 'perl.h') { $dir = '[]'; } - elsif (-f '[-]perl.h') { $dir = '[-]'; } - else { die "$0: Can't find perl.h\n"; } } else { ($junk,$junk,$cpp_file,$cc_cmd) = split(/~~/,$cc_cmd,4); $isgcc = $cc_cmd =~ /case_hack/i or 0; # for nice debug output - $isvaxc = (!$isgcc && $cc_cmd !~ /standard=/i) - or 0; # again, for nice debug output $debugging_enabled = $cc_cmd =~ /\bdebugging\b/i; print "\$isgcc: \\$isgcc\\\n" if $debug; - print "\$isvaxc: \\$isvaxc\\\n" if $debug; print "\$debugging_enabled: \\$debugging_enabled\\\n" if $debug; print "Not running cc, preprocesor output in \\$cpp_file\\\n" if $debug; } @@ -117,33 +130,6 @@ print "\$extnames: \\$extnames\\\n" if $debug; $rtlopt = shift @ARGV; print "\$rtlopt: \\$rtlopt\\\n" if $debug; -# This part gets tricky. VAXC creates global symbols for each of the -# constants in an enum if that enum is ever used as the data type of a -# global[dr]ef. We have to detect enums which are used in this way, so we -# can set up the constants as universal symbols, since anything which -# #includes perl.h will want to resolve these global symbols. -# We're using a weak test here - we basically know that the only enums -# we need to handle now are the big one in opcode.h, and the -# "typedef enum { ... } expectation" in perl.h, so we hard code -# appropriate tests below. Since we can't know in general whether a given -# enum will be used elsewhere in a globaldef, it's hard to decide a -# priori whether its constants need to be treated as global symbols. -sub scan_enum { - my($line) = @_; - - return unless $isvaxc; - - return unless /^\s+(OP|X)/; # we only want opcode and expectation enums - print "\tchecking for enum constant\n" if $debug > 1; - $line =~ s#/\*.+##; - $line =~ s/,?\s*\n?$//; - print "\tfiltered to \\$line\\\n" if $debug > 1; - if ($line =~ /(\w+)$/) { - print "\tconstant name is \\$1\\\n" if $debug > 1; - $enums{$1}++; - } -} - sub scan_var { my($line) = @_; my($const) = $line =~ /^EXTCONST/; @@ -161,65 +147,73 @@ sub scan_var { if ($const) { $cvars{$1}++; } else { $vars{$1}++; } } - if ($isvaxc) { - my($type) = $line =~ /^\s*EXT\w*\s+(\w+)/; - print "\tchecking for use of enum (type is \"$type\")\n" if $debug > 2; - if ($type eq 'expectation') { - $used_expectation_enum++; - print "\tsaw global use of enum \"expectation\"\n" if $debug > 1; - } - if ($type eq 'opcode') { - $used_opcode_enum++; - print "\tsaw global use of enum \"opcode\"\n" if $debug > 1; - } - } } sub scan_func { - my($line) = @_; - - print "\tchecking for global routine\n" if $debug > 1; - if ( $line =~ /(\w+)\s+\(/ ) { - print "\troutine name is \\$1\\\n" if $debug > 1; - if ($1 eq 'main' || $1 eq 'perl_init_ext') { - print "\tskipped\n" if $debug > 1; + my @lines = split /;/, @_[0]; + + for my $line (@lines) { + print "\tchecking for global routine\n" if $debug > 1; + $line =~ s/\b(IV|Off_t|Size_t|SSize_t|void|int)\b//i; + if ( $line =~ /(\w+)\s*\(/ ) { + print "\troutine name is \\$1\\\n" if $debug > 1; + if ($1 eq 'main' || $1 eq 'perl_init_ext' || $1 eq '__attribute__format__' + || $1 eq 'sizeof' || (($1 eq 'Perl_stashpv_hvname_match') && ! $use_threads)) { + print "\tskipped\n" if $debug > 1; + } + else { $fcns{$1}++ } } - else { $fcns{$1}++ } } } +# Go add some right up front if we need 'em +if ($use_mymalloc) { + $fcns{'Perl_malloc'}++; + $fcns{'Perl_calloc'}++; + $fcns{'Perl_realloc'}++; + $fcns{'Perl_mfree'}++; +} + $used_expectation_enum = $used_opcode_enum = 0; # avoid warnings if ($docc) { - open(CPP,"${cc_cmd}/NoObj/PreProc=Sys\$Output ${dir}perl.h|") - or die "$0: Can't preprocess ${dir}perl.h: $!\n"; + 1 while unlink 'perlincludes.tmp'; + END { 1 while unlink 'perlincludes.tmp'; } # and clean up after + + open(PERLINC, '>perlincludes.tmp') or die "Couldn't open 'perlincludes.tmp' $!"; + + print PERLINC qq/#include "${dir}perl.h"\n/; + print PERLINC qq/#include "${dir}perlapi.h"\n/; + print PERLINC qq/#include "${dir}perliol.h"\n/ if $use_perlio; + print PERLINC qq/#include "${dir}regcomp.h"\n/; + + close PERLINC; + $preprocess_list = 'perlincludes.tmp'; + + open(CPP,"${cc_cmd}/NoObj/PreProc=Sys\$Output $preprocess_list|") + or die "$0: Can't preprocess $preprocess_list: $!\n"; } else { open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n"; } -%checkh = map { $_,1 } qw( thread bytecode byterun proto ); +%checkh = map { $_,1 } qw( bytecode byterun intrpvar perlapi perlio perliol + perlvars proto regcomp thrdvar thread ); $ckfunc = 0; LINE: while () { while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) { while (/__VMS_PROTOTYPES__/i .. /__VMS_SEPYTOTORP__/i) { print "vms_proto>> $_" if $debug > 2; - if (/^\s*EXT/) { &scan_var($_); } + if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); } else { &scan_func($_); } last LINE unless defined($_ = ); } print "vmsish.h>> $_" if $debug > 2; - if (/^\s*EXT/) { &scan_var($_); } + if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); } last LINE unless defined($_ = ); } while (/^#.*opcode\.h/i .. /^#.*perl\.h/i) { print "opcode.h>> $_" if $debug > 2; if (/^OP \*\s/) { &scan_func($_); } - if (/^\s*EXT/) { &scan_var($_); } - if (/^\s+OP_/) { &scan_enum($_); } - last LINE unless defined($_ = ); - } - while (/^typedef enum/ .. /^\s*\}/) { - print "global enum>> $_" if $debug > 2; - &scan_enum($_); + if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); } last LINE unless defined($_ = ); } # Check for transition to new header file @@ -234,32 +228,27 @@ LINE: while () { } if ($ckfunc) { print "$scanname>> $_" if $debug > 2; - if (/\s*^EXT/) { &scan_var($_); } + if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); } else { &scan_func($_); } } else { print $_ if $debug > 3 && ($debug > 5 || length($_)); - if (/^\s*EXT/) { &scan_var($_); } + if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); } } } close CPP; - -# Kluge to determine whether we need to add EMBED prefix to -# symbols read from local list. vmsreaddirversions() is a VMS- -# specific function whose Perl_ prefix is added in vmsish.h -# if EMBED is #defined. -$embed = exists($fcns{'Perl_vmsreaddirversions'}) ? 'Perl_' : ''; while () { next if /^#/; s/\s+#.*\n//; next if /^\s*$/; ($key,$array) = split('=',$_); - $key = "$embed$key"; + if ($array eq 'vars') { $key = "PL_$key"; } + else { $key = "Perl_$key"; } print "Adding $key to \%$array list\n" if $debug > 1; ${$array}{$key}++; } -if ($debugging_enabled and ($isvaxc or $isgcc)) { $vars{'colors'}++ } +if ($debugging_enabled and $isgcc) { $vars{'colors'}++ } foreach (split /\s+/, $extnames) { my($pkgname) = $_; $pkgname =~ s/::/__/g; @@ -267,30 +256,6 @@ foreach (split /\s+/, $extnames) { print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug; } -# If we're using VAXC, fold in the names of the constants for enums -# we've seen as the type of global vars. -if ($isvaxc) { - foreach (keys %enums) { - if (/^OP/) { - $vars{$_}++ if $used_opcode_enum; - next; - } - if (/^X/) { - $vars{$_}++ if $used_expectation_enum; - next; - } - print STDERR "Unrecognized enum constant \"$_\" ignored\n"; - } -} -elsif ($isgcc) { - # gcc creates this as a SHR,WRT psect in globals.c, but we - # don't see it in the perl.h scan, since it's only declared - # if DOINIT is #defined. Bleah. It's cheaper to just add - # it by hand than to add /Define=DOINIT to the preprocessing - # run and wade through all the extra junk. - $vars{"${embed}Error"}++; -} - # Eventually, we'll check against existing copies here, so we can add new # symbols to an existing options file in an upwardly-compatible manner. @@ -302,10 +267,18 @@ if ($isvax) { or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n"; print MAR "\t.title perlshr_gbl$marord\n"; } + unless ($isgcc) { - print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,PIC,NOEXE,RD,NOWRT,SHR\n"; - print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,PIC,NOEXE,RD,WRT,NOSHR\n"; + if ($isi64) { + print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,NOEXE,RD,NOWRT,SHR\n"; + print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,NOEXE,RD,WRT,NOSHR\n"; + } + else { + print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,PIC,NOEXE,RD,NOWRT,SHR\n"; + print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,PIC,NOEXE,RD,WRT,NOSHR\n"; + } } +print OPTBLD "case_sensitive=yes\n" if $care_about_case; foreach $var (sort (keys %vars,keys %cvars)) { if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; } else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; } @@ -341,10 +314,7 @@ if ($isvax) { open(OPTATTR,">${dir}perlshr_attr.opt") or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n"; -if ($isvaxc) { - print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n"; -} -elsif ($isgcc) { +if ($isgcc) { foreach $var (sort keys %cvars) { print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n"; } @@ -357,7 +327,7 @@ else { } close OPTATTR; -$incstr = 'perl,globals'; +$incstr = 'PERL,GLOBALS'; if ($isvax) { $drvrname = "Compile_shrmars.tmp_".time; open (DRVR,">$drvrname") or die "$0: Can't write to $drvrname: $!\n"; @@ -387,9 +357,27 @@ if ($isvax) { # Initial hack to permit building of compatible shareable images for a # given version of Perl. if ($ENV{PERLSHR_USE_GSMATCH}) { - my $major = int($] * 1000) & 0xFF; # range 0..255 - my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF; # range 0..255 - print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n"; + if ($ENV{PERLSHR_USE_GSMATCH} eq 'INCLUDE_COMPILE_OPTIONS') { + # Build up a major ID. Since it can only be 8 bits, we encode the version + # number in the top four bits and use the bottom four for build options + # that'll cause incompatibilities + ($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d)/; + $ver += 0; $sub += 0; + $gsmatch = ($sub >= 50) ? "equal" : "lequal"; # Force an equal match for + # dev, but be more forgiving + # for releases + + $ver *=16; + $ver += 8 if $debugging_enabled; # If DEBUGGING is set + $ver += 4 if $use_threads; # if we're threaded + $ver += 2 if $use_mymalloc; # if we're using perl's malloc + print OPTBLD "GSMATCH=$gsmatch,$ver,$sub\n"; + } + else { + my $major = int($] * 1000) & 0xFF; # range 0..255 + my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF; # range 0..255 + print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n"; + } print OPTBLD 'CLUSTER=$$TRANSFER_VECTOR,,', map(",$_$objsuffix",@symfiles), "\n"; } @@ -409,26 +397,5 @@ exec "\$ \@$drvrname" if $isvax; __END__ # Oddball cases, so we can keep the perl.h scan above simple -rcsid=vars # declared in perl.c -regkind=vars # declared in regcomp.h -simple=vars # declared in regcomp.h -varies=vars # declared in regcomp.h -watchaddr=vars # declared in run.c -watchok=vars # declared in run.c -yychar=vars # generated by byacc in perly.c -yycheck=vars # generated by byacc in perly.c -yydebug=vars # generated by byacc in perly.c -yydefred=vars # generated by byacc in perly.c -yydgoto=vars # generated by byacc in perly.c -yyerrflag=vars # generated by byacc in perly.c -yygindex=vars # generated by byacc in perly.c -yylen=vars # generated by byacc in perly.c -yylhs=vars # generated by byacc in perly.c -yylval=vars # generated by byacc in perly.c -yyname=vars # generated by byacc in perly.c -yynerrs=vars # generated by byacc in perly.c -yyrindex=vars # generated by byacc in perly.c -yyrule=vars # generated by byacc in perly.c -yysindex=vars # generated by byacc in perly.c -yytable=vars # generated by byacc in perly.c -yyval=vars # generated by byacc in perly.c +#Foo=vars # uncommented becomes PL_Foo +#Bar=funcs # uncommented becomes Perl_Bar