[perlext] Assorted changes to the compiler

p4raw-id: //depot/perlext/Compiler@531

10 files changed, 85 insertions, 88 deletions

diff --git a/B.pm b/B.pm
index 38787129f1..8545c5c847 100644
--- a/B.pm
+++ b/B.pm
@@ -61,6 +61,7 @@ my @parents = ();
 sub debug {
     my ($class, $value) = @_;
     $debug = $value;
+    walkoptree_debug($value);
 }
 
 # sub OPf_KIDS;
diff --git a/B.xs b/B.xs
index b73464a0e3..729152265d 100644
--- a/B.xs
+++ b/B.xs
@@ -67,9 +67,10 @@ static char *opclassnames[] = {
     "B::COP"	
 };
 
+static int walkoptree_debug = 0;	/* Flag for walkoptree debug hook */
+
 static opclass
-cc_opclass(o)
-OP *	o;
+cc_opclass(OP *o)
 {
     if (!o)
 	return OPc_NULL;
@@ -163,16 +164,13 @@ OP *	o;
 }
 
 static char *
-cc_opclassname(o)
-OP *	o;
+cc_opclassname(OP *o)
 {
     return opclassnames[cc_opclass(o)];
 }
 
 static SV *
-make_sv_object(arg, sv)
-SV *arg;
-SV *sv;
+make_sv_object(SV *arg, SV *sv)
 {
     char *type = 0;
     IV iv;
@@ -192,17 +190,14 @@ SV *sv;
 }
 
 static SV *
-make_mg_object(arg, mg)
-SV *arg;
-MAGIC *mg;
+make_mg_object(SV *arg, MAGIC *mg)
 {
     sv_setiv(newSVrv(arg, "B::MAGIC"), (IV)mg);
     return arg;
 }
 
 static SV *
-cstring(sv)
-SV *sv;
+cstring(SV *sv)
 {
     SV *sstr = newSVpv("", 0);
     STRLEN len;
@@ -255,8 +250,7 @@ SV *sv;
 }
 
 static SV *
-cchar(sv)
-SV *sv;
+cchar(SV *sv)
 {
     SV *sstr = newSVpv("'", 0);
     char *s = SvPV(sv, na);
@@ -295,9 +289,7 @@ SV *sv;
 }
 
 void *
-bset_obj_store(obj, ix)
-void *obj;
-I32 ix;
+bset_obj_store(void *obj, I32 ix)
 {
     if (ix > obj_list_fill) {
 	if (obj_list_fill == -1)
@@ -311,9 +303,7 @@ I32 ix;
 }
 
 #ifdef INDIRECT_BGET_MACROS
-void freadpv(len, data)
-U32 len;
-void *data;
+void freadpv(U32 len, void *data)
 {
     New(666, pv.xpv_pv, len, char);
     fread(pv.xpv_pv, 1, len, (FILE*)data);
@@ -321,8 +311,7 @@ void *data;
     pv.xpv_cur = len - 1;
 }
 
-void byteload_fh(fp)
-FILE *fp;
+void byteload_fh(FILE *fp)
 {
     struct bytestream bs;
     bs.data = fp;
@@ -332,18 +321,14 @@ FILE *fp;
     byterun(bs);
 }
 
-static int fgetc_fromstring(data)
-void *data;
+static int fgetc_fromstring(void *data)
 {
     char **strp = (char **)data;
     return *(*strp)++;
 }
 
-static int fread_fromstring(argp, elemsize, nelem, data)
-char *argp;
-size_t elemsize;
-size_t nelem;
-void *data;
+static int fread_fromstring(char *argp, size_t elemsize, size_t nelem,
+			    void *data)
 {
     char **strp = (char **)data;
     size_t len = elemsize * nelem;
@@ -353,9 +338,7 @@ void *data;
     return (int)len;
 }
 
-static void freadpv_fromstring(len, data)
-U32 len;
-void *data;
+static void freadpv_fromstring(U32 len, void *data)
 {
     char **strp = (char **)data;
     
@@ -366,8 +349,7 @@ void *data;
     *strp += len;
 }    
 
-void byteload_string(str)
-char *str;
+void byteload_string(char *str)
 {
     struct bytestream bs;
     bs.data = &str;
@@ -377,23 +359,19 @@ char *str;
     byterun(bs);
 }
 #else
-void byteload_fh(fp)
-FILE *fp;
+void byteload_fh(FILE *fp)
 {
     byterun(fp);
 }
 
-void byteload_string(str)
-char *str;
+void byteload_string(char *str)
 {
     croak("Must compile with -DINDIRECT_BGET_MACROS for byteload_string");
 }    
 #endif /* INDIRECT_BGET_MACROS */
 
 void
-walkoptree(opsv, method)
-SV *opsv;
-char *method;
+walkoptree(SV *opsv, char *method)
 {
     dSP;
     OP *o;
@@ -402,6 +380,12 @@ char *method;
 	croak("opsv is not a reference");
     opsv = sv_mortalcopy(opsv);
     o = (OP*)SvIV((SV*)SvRV(opsv));
+    if (walkoptree_debug) {
+	PUSHMARK(sp);
+	XPUSHs(opsv);
+	PUTBACK;
+	perl_call_method("walkoptree_debug", G_DISCARD);
+    }
     PUSHMARK(sp);
     XPUSHs(opsv);
     PUTBACK;
@@ -487,6 +471,15 @@ walkoptree(opsv, method)
 	char *	method
 
 int
+walkoptree_debug(...)
+    CODE:
+	RETVAL = walkoptree_debug;
+	if (items > 0 && SvTRUE(ST(1)))
+	    walkoptree_debug = 1;
+    OUTPUT:
+	RETVAL
+
+int
 byteload_fh(fp)
 	FILE *	fp
     CODE:
diff --git a/B/Bytecode.pm b/B/Bytecode.pm
index 81d00b34d9..4fb42ac853 100644
--- a/B/Bytecode.pm
+++ b/B/Bytecode.pm
@@ -1,6 +1,6 @@
 #      Bytecode.pm
 #
-#      Copyright (c) 1996 Malcolm Beattie
+#      Copyright (c) 1996-1998 Malcolm Beattie
 #
 #      You may distribute under the terms of either the GNU General Public
 #      License or the Artistic License, as specified in the README file.
@@ -8,6 +8,7 @@
 package B::Bytecode;
 use strict;
 use Carp;
+use IO::File;
 
 use B qw(minus_c main_cv main_root main_start comppadlist
 	 class peekop walkoptree svref_2object cstring walksymtable);
@@ -28,7 +29,7 @@ sub POK () { 0x04040000 }
 # XXX Shouldn't be hardwired
 sub IOK () { 0x01010000 }
 
-my ($verbose, $module_only, $no_assemble, $debug_cv);
+my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv);
 my $assembler_pid;
 
 # Optimisation options. On the command line, use hyphens instead of
@@ -101,8 +102,7 @@ sub saved { $saved{${$_[0]}} }
 sub mark_saved { $saved{${$_[0]}} = 1 }
 sub unmark_saved { $saved{${$_[0]}} = 0 }
 
-my $debug = 0;
-sub debug { $debug = shift }
+sub debug { $debug_bc = shift }
 
 sub B::OBJECT::nyi {
     my $obj = shift;
@@ -169,6 +169,11 @@ sub B::OP::newix {
     stop($ix);
 }
 
+sub B::OP::walkoptree_debug {
+    my $op = shift;
+    warn(sprintf("walkoptree: %s\n", peekop($op)));
+}
+
 sub B::OP::bytecode {
     my $op = shift;
     my $next = $op->next;
@@ -182,7 +187,7 @@ sub B::OP::bytecode {
     }
     $nextix = $next->objix;
 
-    printf "# %s\n", peekop($op) if $debug;
+    printf "# %s\n", peekop($op) if $debug_bc;
     ldop($ix);
     print "op_next $nextix\n";
     print "op_sibling $sibix\n" unless $strip_syntree;
@@ -286,7 +291,7 @@ sub B::COP::bytecode {
     my $filegv = $op->filegv;
     my $filegvix = $filegv->objix;
     my $line = $op->line;
-    if ($debug) {
+    if ($debug_bc) {
 	printf "# line %s:%d\n", $filegv->SV->PV, $line;
     }
     $op->B::OP::bytecode;
@@ -305,8 +310,6 @@ EOT
 
 sub B::PMOP::bytecode {
     my $op = shift;
-    my $short = $op->pmshort;
-    my $shortix = $short->objix;
     my $replroot = $op->pmreplroot;
     my $replrootix = $replroot->objix;
     my $replstartix = $op->pmreplstart->objix;
@@ -314,7 +317,6 @@ sub B::PMOP::bytecode {
     # pmnext is corrupt in some PMOPs (see misc.t for example)
     #my $pmnextix = $op->pmnext->objix;
 
-    $short->bytecode;
     if ($$replroot) {
 	# OP_PUSHRE (a mutated version of OP_MATCH for the regexp
 	# argument to a split) stores a GV in op_pmreplroot instead
@@ -333,11 +335,9 @@ sub B::PMOP::bytecode {
     }
     my $re = pvstring($op->precomp);
     # op_pmnext omitted since a perl bug means it's sometime corrupt
-    printf <<"EOT", $op->pmflags, $op->pmpermflags, $op->pmslen;
-op_pmshort $shortix
+    printf <<"EOT", $op->pmflags, $op->pmpermflags;
 op_pmflags 0x%x
 op_pmpermflags 0x%x
-op_pmslen %d
 newpv $re
 pregcomp
 EOT
@@ -651,13 +651,19 @@ sub bytecompile_main {
     my $curpadix = $curpad->objix;
     $curpad->bytecode;
     walkoptree(main_root, "bytecode");
+    warn "done main program, now walking symbol table\n" if $debug_bc;
     my ($pack, %exclude);
-    foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS
-		      strict vars FileHandle Exporter Carp)) {
+    foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS strict vars
+		      FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol
+		      SelectSaver blib Cwd))
+    {
 	$exclude{$pack."::"} = 1;
     }
     no strict qw(vars refs);
-    walksymtable(\%{"main::"}, "bytecodecv",sub { !defined($exclude{$_[0]}) });
+    walksymtable(\%{"main::"}, "bytecodecv", sub {
+	warn "considering $_[0]\n" if $debug_bc;
+	return !defined($exclude{$_[0]});
+    });
     if (!$module_only) {
 	printf "main_root %d\n", main_root->objix;
 	printf "main_start %d\n", main_start->objix;
@@ -666,28 +672,23 @@ sub bytecompile_main {
     }
 }
 
-sub prepare_output {
-    # Plumbing for output
-    if (!$no_assemble) {
-	pipe(READER, WRITER) or die "pipe: $!\n";
-	$assembler_pid = fork();
-	die "fork: $!\n" unless defined($assembler_pid);
-	if ($assembler_pid) {
-	    # parent
-	    close WRITER;
-	    assemble_fh(\*READER, sub { print @_ });
-	    exit(0);
-	} else {
-	    # child
-	    close READER;
-	    open(STDOUT, ">&WRITER") or die "dup: $!\n";
-	}
-    }
+sub prepare_assemble {
+    my $newfh = IO::File->new_tmpfile;
+    select($newfh);
+    return $newfh;
+}
+
+sub do_assemble {
+    my $fh = shift;
+    seek($fh, 0, 0); # rewind the temporary file
+    assemble_fh($fh, sub { print OUT @_ });
 }
 
 sub compile {
     my @options = @_;
     my ($option, $opt, $arg);
+    open(OUT, ">&STDOUT");
+    select(OUT);
   OPTION:
     while ($option = shift @options) {
 	if ($option =~ /^-(.)(.*)/) {
@@ -702,11 +703,14 @@ sub compile {
 	    last OPTION;
 	} elsif ($opt eq "o") {
 	    $arg ||= shift @options;
-	    open(STDOUT, ">$arg") or return "$arg: $!\n";
+	    open(OUT, ">$arg") or return "$arg: $!\n";
 	} elsif ($opt eq "D") {
 	    $arg ||= shift @options;
 	    foreach $arg (split(//, $arg)) {
-		if ($arg eq "o") {
+		if ($arg eq "b") {
+		    $| = 1;
+		    debug(1);
+		} elsif ($arg eq "o") {
 		    B->debug(1);
 		} elsif ($arg eq "a") {
 		    B::Assembler::debug(1);
@@ -751,17 +755,19 @@ sub compile {
     if (@options) {
 	return sub {
 	    my $objname;
-	    prepare_output();
+	    my $newfh; 
+	    $newfh = prepare_assemble() unless $no_assemble;
 	    foreach $objname (@options) {
 		eval "bytecompile_object(\\$objname)";
 	    }
-	    waitpid($assembler_pid, 0) if defined($assembler_pid);
+	    do_assemble($newfh) unless $no_assemble;
 	}
     } else {
 	return sub {
-	    prepare_output();
+	    my $newfh; 
+	    $newfh = prepare_assemble() unless $no_assemble;
 	    bytecompile_main();
-	    waitpid($assembler_pid, 0) if defined($assembler_pid);
+	    do_assemble($newfh) unless $no_assemble;
 	}
     }
 }
diff --git a/B/C.pm b/B/C.pm
index 6443893492..e0186ef2cc 100644
--- a/B/C.pm
+++ b/B/C.pm
@@ -746,7 +746,7 @@ sub B::AV::save {
 		   "\tav_extend(av, $fill);",
 		   "\tsvp = AvARRAY(av);",
 	       map("\t*svp++ = (SV*)$_;", @names),
-		   "\tAvFILL(av) = $fill;",
+		   "\tAvFILLp(av) = $fill;",
 		   "}");
     } else {
 	my $max = $av->MAX;
diff --git a/B/Debug.pm b/B/Debug.pm
index 1a78f39165..d88cef3780 100644
--- a/B/Debug.pm
+++ b/B/Debug.pm
@@ -59,9 +59,7 @@ sub B::PMOP::debug {
     printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
     printf "\top_pmnext\t0x%x\n", ${$op->pmnext};
     printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);
-    printf "\top_pmshort\t0x%x\n", ${$op->pmshort};
     printf "\top_pmflags\t0x%x\n", $op->pmflags;
-    printf "\top_pmslen\t%d\n", $op->pmslen;
     $op->pmshort->debug;
     $op->pmreplroot->debug;
 }
diff --git a/NOTES b/NOTES
index 7640e542e4..ee10ba03e9 100644
--- a/NOTES
+++ b/NOTES
@@ -126,6 +126,7 @@ Bytecode backend invocation
 			-O6 adds -fstrip-syntax-tree.
 	-D		Debug options (concat or separate flags like perl -D)
 		o	OPs, prints each OP as it's processed.
+		b	print debugging information about bytecompiler progress
 		a	tells the assembler to include source assembler lines
 			in its output as bytecode comments.
 		C	prints each CV taken from the final symbol tree walk.
diff --git a/O.pm b/O.pm
index cc9f7f96f3..40d336e122 100644
--- a/O.pm
+++ b/O.pm
@@ -2,15 +2,13 @@ package O;
 use B qw(minus_c);
 use Carp;    
 
-my $compilesub;
-
 sub import {
     my ($class, $backend, @options) = @_;
     eval "use B::$backend ()";
     if ($@) {
 	croak "use of backend $backend failed: $@";
     }
-    $compilesub = &{"B::${backend}::compile"}(@options);
+    my $compilesub = &{"B::${backend}::compile"}(@options);
     if (ref($compilesub) eq "CODE") {
 	minus_c;
 	eval 'END { &$compilesub() }';
diff --git a/bytecode.pl b/bytecode.pl
index 0dd7c1e4df..d7532136b8 100644
--- a/bytecode.pl
+++ b/bytecode.pl
@@ -310,7 +310,7 @@ xcv_outside	*(SV**)&CvOUTSIDE(sv)	svindex
 xcv_flags	CvFLAGS(sv)		U8
 av_extend	sv			SSize_t		x
 av_push		sv			svindex		x
-xav_fill	AvFILL(sv)		SSize_t
+xav_fill	AvFILLp(sv)		SSize_t
 xav_max		AvMAX(sv)		SSize_t
 xav_flags	AvFLAGS(sv)		U8
 xhv_riter	HvRITER(sv)		I32
diff --git a/byterun.c b/byterun.c
index 6b242e55b1..3d4b64fb9d 100644
--- a/byterun.c
+++ b/byterun.c
@@ -405,7 +405,7 @@ FILE *fp;
 	    {
 		SSize_t arg;
 		BGET_I32(arg);
-		AvFILL(sv) = arg;
+		AvFILLp(sv) = arg;
 		break;
 	    }
 	  case INSN_XAV_MAX:		/* 56 */
diff --git a/typemap b/typemap
index ed4aecc403..7206a6a2e1 100644
--- a/typemap
+++ b/typemap
@@ -62,7 +62,7 @@ T_OP_OBJ
 	sv_setiv(newSVrv($arg, cc_opclassname((OP*)$var)), (IV)$var);
 
 T_SV_OBJ
-	make_sv_object(($arg), ($var));
+	make_sv_object(($arg), (SV*)($var));
 
 
 T_MG_OBJ