X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fgen_shrfls.pl;h=7ba40fd5afc5ad8b67ba4153fb05640cb7b4df09;hb=fe578d7fdd84ab0398dc36da7f84e59e1f2bb290;hp=043faccb0981905d5cdef2e99a5d5fd94d1a6d86;hpb=748a93069b3d16374a9859d1456065dd3ae11394;p=p5sagit%2Fp5-mst-13.2.git diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl index 043facc..7ba40fd 100644 --- a/vms/gen_shrfls.pl +++ b/vms/gen_shrfls.pl @@ -33,33 +33,90 @@ # library has everything old one did # (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)? # -# Author: Charles Bailey bailey@genetics.upenn.edu -# Revised: 01-Mar-1995 +# Author: Charles Bailey bailey@newman.upenn.edu require 5.000; $debug = $ENV{'GEN_SHRFLS_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"; + print "Input taken from file $ARGV[1]\n" if $debug; + @ARGV = (); + while () { + chomp; + push(@ARGV,split(/\|/,$_)); + } + close INP; + print "Read input data | ",join(' | ',@ARGV)," |\n" if $debug > 1; +} + $cc_cmd = shift @ARGV; + +# Someday, we'll have $GetSyI built into perl . . . +$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 !~ /~~NOCC~~/); +$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/; @defines = split(/,/,$defines); $cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines)) . ')' . $suffix; } print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug; - if (-f 'perl.h') { $dir = '[]'; } - elsif (-f '[-]perl.h') { $dir = '[-]'; } - else { die "$0: Can't find perl.h\n"; } + # check for gcc - if present, we'll need to use MACRO hack to + # define global symbols for shared variables + + print "\$isgcc: $isgcc\n" if $debug; + print "\$debugging_enabled: $debugging_enabled\n" if $debug; + +} +else { + ($junk,$junk,$cpp_file,$cc_cmd) = split(/~~/,$cc_cmd,4); + $isgcc = $cc_cmd =~ /case_hack/i + or 0; # for nice debug output + $debugging_enabled = $cc_cmd =~ /\bdebugging\b/i; + print "\$isgcc: \\$isgcc\\\n" if $debug; + print "\$debugging_enabled: \\$debugging_enabled\\\n" if $debug; + print "Not running cc, preprocesor output in \\$cpp_file\\\n" if $debug; } -else { ($cpp_file) = ($cc_cmd =~ /~~NOCC~~(.*)/) } $objsuffix = shift @ARGV; print "\$objsuffix: \\$objsuffix\\\n" if $debug; @@ -73,85 +130,130 @@ print "\$extnames: \\$extnames\\\n" if $debug; $rtlopt = shift @ARGV; print "\$rtlopt: \\$rtlopt\\\n" if $debug; -# Someday, we'll have $GetSyI built into perl . . . -$isvax = `\$ Write Sys\$Output F\$GetSyI(\"HW_MODEL\")` <= 1024; -print "\$isvax: \\$isvax\\\n" if $debug; - sub scan_var { my($line) = @_; + my($const) = $line =~ /^EXTCONST/; print "\tchecking for global variable\n" if $debug > 1; - $line =~ s/INIT\(.*\)//; + $line =~ s/\s*EXT/EXT/; + $line =~ s/INIT\s*\(.*\)//; $line =~ s/\[.*//; $line =~ s/=.*//; $line =~ s/\W*;?\s*$//; + $line =~ s/\W*\)\s*\(.*$//; # closing paren for args stripped in previous stmt print "\tfiltered to \\$line\\\n" if $debug > 1; if ($line =~ /(\w+)$/) { - print "\tvar name is \\$1\\\n" if $debug > 1; - $vars{$1}++; + print "\tvar name is \\$1\\" . ($const ? ' (const)' : '') . "\n" if $debug > 1; + if ($const) { $cvars{$1}++; } + else { $vars{$1}++; } } } sub scan_func { - my($line) = @_; + my @lines = split /;/, @_[0]; - print "\tchecking for global routine\n" if $debug > 1; - if ( /(\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; + 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 { $funcs{$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 $cpp_file: $!\n"; + open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n"; } +%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; - &scan_func($_); - if (/^EXT/) { &scan_var($_); } - last LINE unless $_ = ; + if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); } + else { &scan_func($_); } + last LINE unless defined($_ = ); } print "vmsish.h>> $_" if $debug > 2; - if (/^EXT/) { &scan_var($_); } - last LINE unless $_ = ; + 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 (/^EXT/) { &scan_var($_); } - last LINE unless $_ = ; + if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); } + last LINE unless defined($_ = ); + } + # Check for transition to new header file + if (/^# \d+ "(\S+)"/) { + my $spec = $1; + # Pull name from library module or header filespec + $spec =~ /^(\w+)$/ or $spec =~ /(\w+)\.h/i; + my $name = lc $1; + $ckfunc = exists $checkh{$name} ? 1 : 0; + $scanname = $name if $ckfunc; + print "Header file transition: ckfunc = $ckfunc for $name.h\n" if $debug > 1; + } + if ($ckfunc) { + print "$scanname>> $_" if $debug > 2; + if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); } + else { &scan_func($_); } } - while (/^#.*proto\.h/i .. /^#.*perl\.h/i) { - print "proto.h>> $_" if $debug > 2; - &scan_func($_); - if (/^EXT/) { &scan_var($_); } - last LINE unless $_ = ; + else { + print $_ if $debug > 3 && ($debug > 5 || length($_)); + if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); } } - print $_ if $debug > 3; - if (/^EXT/) { &scan_var($_); } } close CPP; + while () { next if /^#/; s/\s+#.*\n//; + next if /^\s*$/; ($key,$array) = split('=',$_); + 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 $isgcc) { $vars{'colors'}++ } foreach (split /\s+/, $extnames) { my($pkgname) = $_; $pkgname =~ s/::/__/g; - $funcs{"boot_$pkgname"}++; - print "Adding boot_$pkgname to \%funcs (for extension $_)\n" if $debug; + $fcns{"boot_$pkgname"}++; + print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug; } # Eventually, we'll check against existing copies here, so we can add new @@ -160,19 +262,28 @@ foreach (split /\s+/, $extnames) { $marord++; open(OPTBLD,">${dir}${dbgprefix}perlshr_bld.opt") or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n"; -open(OPTATTR,">${dir}perlshr_attr.opt") - or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n"; if ($isvax) { open(MAR,">${dir}perlshr_gbl${marord}.mar") or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n"; print MAR "\t.title perlshr_gbl$marord\n"; } -print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n"; -foreach $var (sort keys %vars) { - print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; + +unless ($isgcc) { + 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"; } - if ($isvax) { + # This hack brought to you by the lack of a globaldef in gcc. + if ($isgcc) { if ($count++ > 200) { # max 254 psects/file print MAR "\t.end\n"; close MAR; @@ -182,27 +293,42 @@ foreach $var (sort keys %vars) { print MAR "\t.title perlshr_gbl$marord\n"; $count = 0; } - # This hack brought to you by the lack of a globaldef in gcc. print MAR "\t.psect ${var},long,pic,ovr,rd,wrt,noexe,noshr\n"; print MAR "\t${var}:: .blkl 1\n"; } } print MAR "\t.psect \$transfer_vec,pic,rd,nowrt,exe,shr\n" if ($isvax); -foreach $func (sort keys %funcs) { +foreach $func (sort keys %fcns) { if ($isvax) { print MAR "\t.transfer $func\n"; print MAR "\t.mask $func\n"; - print MAR "\tjmp L\^${func}+2\n"; + print MAR "\tjmp G\^${func}+2\n"; } else { print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n"; } } - -close OPTATTR; -$incstr = 'perl,globals'; if ($isvax) { print MAR "\t.end\n"; close MAR; +} + +open(OPTATTR,">${dir}perlshr_attr.opt") + or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n"; +if ($isgcc) { + foreach $var (sort keys %cvars) { + print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n"; + } + foreach $var (sort keys %vars) { + print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; + } +} +else { + print OPTATTR "! No additional linker directives are needed when using DECC\n"; +} +close OPTATTR; + +$incstr = 'PERL,GLOBALS'; +if ($isvax) { $drvrname = "Compile_shrmars.tmp_".time; open (DRVR,">$drvrname") or die "$0: Can't write to $drvrname: $!\n"; print DRVR "\$ Set NoOn\n"; @@ -213,7 +339,7 @@ if ($isvax) { print DRVR "\$ Set Verify\n"; print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n"; do { - $incstr .= ",perlshr_gbl$marord"; + push(@symfiles,"perlshr_gbl$marord"); print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n"; print DRVR "\$ Library/Object/Replace/Log $libperl PerlShr_Gbl${marord}$objsuffix\n"; } while (--$marord); @@ -228,11 +354,39 @@ if ($isvax) { close DRVR; } +# Initial hack to permit building of compatible shareable images for a +# given version of Perl. +if ($ENV{PERLSHR_USE_GSMATCH}) { + 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"; +} +elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); } # Include object modules and RTLs in options file # Linker wants /Include and /Library on different lines print OPTBLD "$libperl/Include=($incstr)\n"; print OPTBLD "$libperl/Library\n"; -open(RTLOPT,$rtlopt) or die "$0: Can't read $rtlopt: $!\n"; +open(RTLOPT,$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n"; while () { print OPTBLD; } close RTLOPT; close OPTBLD; @@ -243,29 +397,5 @@ exec "\$ \@$drvrname" if $isvax; __END__ # Oddball cases, so we can keep the perl.h scan above simple -error=vars # declared in perl.h only when DOINIT defined by INTERN.h -rcsid=vars # declared in perl.c -regarglen=vars # declared in regcomp.h -regdummy=vars # declared in regcomp.h -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