[perlext] Assorted changes to the compiler

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

diff --git a/B.pm b/B.pm
index 3878712..8545c5c 100644 (file)
--- 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 b73464a..7291522 100644 (file)
--- 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 81d00b3..4fb42ac 100644 (file)
--- 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 6443893..e0186ef 100644 (file)
--- 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 1a78f39..d88cef3 100644 (file)
--- 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 7640e54..ee10ba0 100644 (file)
--- 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 cc9f7f9..40d336e 100644 (file)
--- 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 0dd7c1e..d753213 100644 (file)
--- 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 6b242e5..3d4b64f 100644 (file)
--- 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 ed4aecc..7206a6a 100644 (file)
--- 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