B-C-1.04_09

git-svn-id: http://perl-compiler.googlecode.com/svn/trunk@10 ed534f1a-1453-0410-ab30-dfc593a8b23c

Changes

@@ -1,6 +1,10 @@
 Started with B-C-1.04_01. The perl compiler was previously in CORE.
 TODO: Try to get info about earlier versions.
 
+1.04_09 2008-02-23 rurban
+	* make t/test*.sh PERL independent
+	* fixed B::C GV init crashes (SvPOK assertion)
+
 1.04_08 2008-02-22 rurban
 	* fixed t/b.t tests for 5.11 (REGEXP, ref RV => IV)
 	* fixed Makefile.PL deps to ignore the interim .pl files

META.yml

@@ -1,6 +1,6 @@
 --- #YAML:1.0
 name:                B-C
-version:             1.04_08
+version:             1.04_09
 abstract:            ~
 license:             ~
 author:              ~

Makefile.PL

@@ -1,7 +1,7 @@
 use ExtUtils::MakeMaker;
 use Config;
 use File::Spec;
-use 5.009005;
+#use 5.009005;
 
 my $core = grep { $_ eq 'PERL_CORE=1' } @ARGV;
 

NOTES

@@ -23,6 +23,7 @@ C backend invocation
 		A	prints AV information on saving
 		C	prints CV information on saving
 		M	prints MAGIC information on saving
+		G	prints GV information on saving
 	-f		Force optimisations on or off one at a time.
 		cog	Copy-on-grow: PVs declared and initialised statically
 		no-cog	No copy-on-grow

bytecode.pl

@@ -351,6 +351,8 @@ =head1 DESCRIPTION
 
 A simple mapping of the op type number to its type (like 'COP' or 'BINOP').
 
+Since Perl version 5.10 defined in L<B>.
+
 =item @specialsv_name
 
   my $sv_name = $specialsv_name[$sv_index];
@@ -360,6 +362,8 @@ =head1 DESCRIPTION
 This array maps that number back to the name of the SV (like 'Nullsv'
 or '&PL_sv_undef').
 
+Since Perl version 5.10 defined in L<B>.
+
 =back
 
 =head1 AUTHOR

lib/B/Asmdata.pm

@@ -223,6 +223,8 @@ Suitable for using with %insn_data like so:
 
 A simple mapping of the op type number to its type (like 'COP' or 'BINOP').
 
+Since Perl version 5.10 defined in L<B>.
+
 =item @specialsv_name
 
   my $sv_name = $specialsv_name[$sv_index];
@@ -232,6 +234,8 @@ B::SPECIAL and are referred to by a number from the specialsv_list.
 This array maps that number back to the name of the SV (like 'Nullsv'
 or '&PL_sv_undef').
 
+Since Perl version 5.10 defined in L<B>.
+
 =back
 
 =head1 AUTHOR

lib/B/C.pm

@@ -1,14 +1,15 @@
 #      C.pm
 #
 #      Copyright (c) 1996, 1997, 1998 Malcolm Beattie
+#      Copyright (c) 2008 Reini Urban
 #
 #      You may distribute under the terms of either the GNU General Public
 #      License or the Artistic License, as specified in the README file.
 #
 
 package B::C;
 
-our $VERSION = '1.04_08';
+our $VERSION = '1.04_09';
 
 package B::C::Section;
 
@@ -218,7 +219,7 @@ my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
     $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
     $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
     $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
-    $xrvsect, $xpvbmsect, $xpviosect );
+    $xrvsect, $xpvbmsect, $xpviosect, $heksect );
 my @op_sections = \( $binopsect, $condopsect, $copsect, $padopsect, $listopsect,
                      $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect,
                      $unopsect );
@@ -324,6 +325,16 @@ sub save_pv_or_rv {
     return ( $savesym, $pvmax, $len, $pv );
 }
 
+# FIXME! global string table
+sub save_hek {
+  my $str = shift;
+  my $len = length $str;
+  my $hash = 0; # let hv compute it
+  # (HEK*)ptr_table_fetch(PL_ptr_table, source);
+  # FIXME!
+  $heksect->add("hv_store(PL_strtab, \"$str\", $len, NULL, $hash);");
+}
+
 # see also init_op_ppaddr below; initializes the ppaddt to the
 # OpTYPE; init_op_ppaddr iterates over the ops and sets
 # op_ppaddr to PL_ppaddr[op_ppaddr]; this avoids an explicit assignmente
@@ -362,7 +373,7 @@ sub B::OP::fake_ppaddr {
   else               {  $static = '0, 0, 0, 0, 0'; } # opt latefree latefreed attached spare
   sub B::OP::_save_common_middle {
     my $op = shift;
-    my $madprop = $mad ? (" ".($B::VERSION < 1.1801 ? 0:$op->madprop) . ",") : "";
+    my $madprop = $mad ? (" ".($B::VERSION < 1.1801 ? 0 : $op->madprop) . ",") : "";
     sprintf ("%s,%s %u, %u, $static, 0x%x, 0x%x",
 	     $op->fake_ppaddr, $madprop, $op->targ, $op->type,
 	     $op->flags, $op->private);
@@ -1129,12 +1140,28 @@ sub B::GV::save {
 	    $egvsym = $egv->save;
 	}
     }
-    $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
-	       sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS ),
+    $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);]);
+    # XXX hack Remove SVpgv_GP (GV has a valid GP) SvFLAGS(sv) &= ~SVpgv_GP
+    # 5.8 had SvFLAGS 0x600d, 5.11 has 0x8009
+    my $svflags = $gv->FLAGS;
+    if ($gv->isGV_with_GP and $is_empty) {
+      warn(sprintf("gv[$name]_with_GP: 0x%x %s %s %s\n", $gv->FLAGS,
+		   $gv->FILE, $gv->FILEGV, $gv->GP)) if $debug_gv;
+      $svflags = $gv->FLAGS && 0x8000 ? $gv->FLAGS - 0x8000 : $gv->FLAGS;
+      warn("Removing empty GP from $name\n") if $debug_gv;
+    } elsif (!$is_empty) {
+      $init->add(sprintf("GvGP($sym) = Perl_newGP(aTHX_ $sym); /* 0x%x */", $gv->GP));
+      # $svflags = $gv->FLAGS && 0x400 ? $gv->FLAGS : $gv->FLAGS + 0x400;
+      warn(sprintf("Setting GvGP of $name: 0x%x %s %s %s\n", $svflags,
+		   $gv->FILE, $gv->FILEGV, $gv->GP)) if $debug_gv;
+    }
+    $init->add(sprintf("SvFLAGS($sym) = 0x%x;", $svflags ),
 	       sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
     $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
-    # XXX hack for when Perl accesses PVX of GVs
-    $init->add("SvPVX($sym) = emptystring;\n");
+    # XXX hack for when Perl accesses PVX of GVs, only if SvPOK
+    #if (!($svflags && 0x400)) {
+    $init->add("if (SvPOK($sym)) SvPVX($sym) = emptystring;\n") unless $is_empty;
+    #}
     # Shouldn't need to do save_magic since gv_fetchpv handles that
     #$gv->save_magic;
     # XXX will always be > 1!!!
@@ -1148,7 +1175,7 @@ sub B::GV::save {
     if ($gvrefcnt > 1) {
 	$init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
     }
-    # some non-alphavetic globs require some parts to be saved
+    # some non-alphabetic globs require some parts to be saved
     # ( ex. %!, but not $! )
     sub Save_HV() { 1 }
     sub Save_AV() { 2 }
@@ -1205,18 +1232,22 @@ sub B::GV::save {
                 $init->add("\tcv=perl_get_cv($origname,TRUE);");
                 $init->add("\tGvCV($sym)=cv;");
                 $init->add("\tSvREFCNT_inc((SV *)cv);");
-                $init->add("}");    
+                $init->add("}");
 	    } else {
                $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
 	       warn "GV::save &$name\n" if $debug_gv;
 	    }
         }
-	if ($] < 5.009) {
+	if ($] > 5.009) {
+	  my $file = cstring($gv->FILE);
+	  $heksect->add($file);
+	  $init->add(sprintf("GvFILE_HEK($sym) = share_hek(%s,%u,0);",
+			     $file, length($file)));
+	  warn "GV::save GvFILE_HEK(*$name) = share_hek($file)\n" if $debug_gv;
+	}  else {
 	  $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
-	} else {
-	  $init->add(sprintf("GvFILE_HEK($sym) = %s;", cstring($gv->FILE)));
+	  warn "GV::save GvFILE(*$name) = ".cstring($gv->FILE)."\n" if $debug_gv;
 	}
-	warn "GV::save GvFILE".($[ < 5.009 ? "" : "_HEK")."(*$name)\n" if $debug_gv;
 	my $gvform = $gv->FORM;
 	if ($$gvform && $savefields&Save_FORM) {
 	    $gvform->save;
@@ -1740,7 +1771,7 @@ xs_init(pTHX)
     dTARG;
     dSP;
 EOT
-    print "\n#undef USE_DYNAMIC_LOADING"; # REMOVEME! boot_ symbols not linked!
+    print "\n#undef USE_DYNAMIC_LOADING /* temp. HACK! */"; # REMOVEME! boot_ symbols not linked!
     print "\n#ifdef USE_DYNAMIC_LOADING";
     print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
     print "\n#endif\n" ;
@@ -2062,6 +2093,7 @@ sub save_main {
 
 sub init_sections {
     my @sections = (decl => \$decl, sym => \$symsect,
+		    hek => \$heksect,
 		    binop => \$binopsect, condop => \$condopsect,
 		    cop => \$copsect, padop => \$padopsect,
 		    listop => \$listopsect, logop => \$logopsect,

script/perlcc.PL

@@ -173,7 +173,6 @@ sub parse_argv {
         'c',            # Compile only
         'h',            # Help me
         'S',            # Dump C files
-	'r',            # run the resulting executable
         'T',            # run the backend using perl -T
         't',            # run the backend using perl -t
         'static',       # Dirty hack to enable -shared/-static
@@ -300,9 +299,9 @@ sub compile_cstyle {
     vprint 1, "Compiling...";
     vprint 1, "Calling $command";
 
-	my ($output_r, $error_r) = spawnit($command);
-	my @output = @$output_r;
-	my @error = @$error_r;
+    my ($output_r, $error_r) = spawnit($command);
+    my @output = @$output_r;
+    my @error = @$error_r;
 
     if (@error && $? != 0) {
         _die("$0: $Input did not compile, which can't happen:\n@error\n");

t/testc.sh

@@ -1,19 +1,31 @@
-OCMD="perl5.11.0 -Mblib -MO=C,-DcACMSG,"
-CCMD="gcc -pipe -DDEBUGGING -DPERL_USE_SAFE_PUTENV -U__STRICT_ANSI__ -fno-strict-aliasing -I/usr/lib/perl5/5.11/i686-cygwin/CORE -O0 -g"
-LCMD=" -Wl,--enable-auto-import -Wl,--export-all-symbols -L/usr/lib/perl5/5.11/i686-cygwin/CORE -lperl -ldl -lcrypt -lgdbm_compat"
+#!/bin/sh
+# use the actual perl from the Makefile (perld, perl5.11.0, ...)
+PERL=`grep "^PERL =" Makefile|cut -c8-`
+# if $] < 5.9 then remove -Mblib
+# OCMD="$PERL -Mblib -MO=C,-DcACMSG,"
+OCMD="$PERL `$PERL -e'print (($] < 5.009004) ? q() : q(-Mblib))'` -MO=C,-DcACMSG," 
+CCMD="$PERL script/cc_harness -g"
+LCMD=
+#CCMD="gcc -pipe -DDEBUGGING -DPERL_USE_SAFE_PUTENV -U__STRICT_ANSI__ -fno-strict-aliasing -I/usr/lib/perl5/5.11/i686-cygwin/CORE -O0 -g"
+#LCMD=" -Wl,--enable-auto-import -Wl,--export-all-symbols -L/usr/lib/perl5/5.11/i686-cygwin/CORE -lperl -ldl -lcrypt -lgdbm_compat"
 
 make
 echo "print 'hi'" > ccode1.pl
 echo ${OCMD}-occode1.c ccode1.pl
 ${OCMD}-occode1.c ccode1.pl
+echo $CCMD ccode1.c -c -E -o ccode1.cee
+$CCMD ccode1.c -c -E -o ccode1.cee
 echo $CCMD ccode1.c $LCMD -o ccode1.exe
 $CCMD ccode1.c $LCMD -o ccode1.exe
-$CCMD ccode1.c -E -o ccode1.cee
+test -x ccode1 || exit
+./ccode1 || exit
 
-test -e ccode1.exe || exit
 echo "for (1,2,3) { print if /\d/ }" > ccode2.pl
 echo ${OCMD}-occode2.c ccode2.pl
 ${OCMD}-occode2.c ccode2.pl
+echo $CCMD ccode2.c -c -E -o ccode2.cee
+$CCMD ccode2.c -c -E -o ccode2.cee
 echo $CCMD ccode2.c $LCMD -o ccode2.exe
 $CCMD ccode2.c $LCMD -o ccode2.exe
-$CCMD ccode2.c -E -o ccode2.cee
+test -x ccode2 || exit
+./ccode2

t/testplc.sh

@@ -1,5 +1,7 @@
 #!/bin/sh
-PERL=perl5.11.0
+# use the actual perl from the Makefile (perld, perl5.10.0, perl5.8.8, perl5.11.0, ...)
+PERL=`grep "^PERL =" Makefile|cut -c8-`
+#PERL=perl5.11.0
 OCMD="$PERL -Mblib -MO=Bytecode,"
 ICMD="$PERL -Mblib -MByteLoader"
 
@@ -36,7 +38,7 @@ $PERL -Mblib -MO=Concise bytecode2.pl > bytecode2.concise
 echo ${ICMD} bytecode2.plc
 ${ICMD} bytecode2.plc
 fi
-#only if ByteLoader installed
+#only if ByteLoader installed in @INC
 if false; then
 echo ${OCMD}-H,-obytecode2.plc bytecode2.pl
 ${OCMD}-H,-obytecode2.plc bytecode2.pl
@@ -51,4 +53,4 @@ echo "package MY::Test;" > bytecode1.pm
 echo "print 'hi'" >> bytecode1.pm
 echo ${OCMD}-m,-obytecode1.pmc bytecode1.pm
 ${OCMD}-obytecode1.pmc bytecode1.pm
-fi
+fi