B::Bytecode patches

To: gsar@activestate.com, jhi@iki.fi
Cc: perl5-porters@perl.org
Message-ID: <20000602202526.48694.qmail@hotmail.com>
(MUA had mangled many lines by wordwrapping)

p4raw-id: //depot/cfgperl@6204

diff --git a/bytecode.pl b/bytecode.pl
index d1e1c70..f847298 100644 (file)
--- a/bytecode.pl
+++ b/bytecode.pl
@@ -13,7 +13,7 @@ my @optype= qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP);
 
 # Nullsv *must* come first in the following so that the condition
 # ($$sv == 0) can continue to be used to test (sv == Nullsv).
-my @specialsv = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no);
+my @specialsv = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE);
 
 my (%alias_from, $from, $tos);
 while (($from, $tos) = each %alias_to) {
@@ -82,7 +82,7 @@ print BYTERUN_C $c_header, <<'EOT';
 #include "bytecode.h"
 
 
-static int optype_size[] = {
+static const int optype_size[] = {
 EOT
 my $i = 0;
 for ($i = 0; $i < @optype - 1; $i++) {
@@ -92,12 +92,8 @@ printf BYTERUN_C "    sizeof(%s)\n", $optype[$i], $i;
 print BYTERUN_C <<'EOT';
 };
 
-static SV *specialsv_list[4];
-
 static int bytecode_iv_overflows = 0;
-static SV *bytecode_sv;
-static XPV bytecode_pv;
-static void **bytecode_obj_list;
+static void **bytecode_obj_list = Null(void**);
 static I32 bytecode_obj_list_fill = -1;
 
 void *
@@ -105,9 +101,9 @@ bset_obj_store(pTHXo_ void *obj, I32 ix)
 {
     if (ix > bytecode_obj_list_fill) {
        if (bytecode_obj_list_fill == -1)
-           New(666, bytecode_obj_list, ix + 1, void*);
+           New(666, bytecode_obj_list, ix + 32, void*);
        else
-           Renew(bytecode_obj_list, ix + 1, void*);
+           Renew(bytecode_obj_list, ix + 32, void*);
        bytecode_obj_list_fill = ix;
     }
     bytecode_obj_list[ix] = obj;
@@ -115,11 +111,20 @@ bset_obj_store(pTHXo_ void *obj, I32 ix)
 }
 
 void
-byterun(pTHXo_ struct bytestream bs)
+byterun(pTHXo)
 {
     dTHR;
     int insn;
-
+    SV *bytecode_sv;
+    XPV bytecode_pv;
+    SV *specialsv_list[6];
+    ENTER;
+    SAVEVPTR(bytecode_obj_list);
+    SAVEI32(bytecode_obj_list_fill);
+    bytecode_obj_list = Null(void**);
+    bytecode_obj_list_fill = -1;
+
+    BYTECODE_HEADER_CHECK;     /* croak if incorrect platform */
 EOT
 
 for (my $i = 0; $i < @specialsv; $i++) {
@@ -198,7 +203,7 @@ EOT
 #
 open(BYTERUN_H, ">ext/ByteLoader/byterun.h") or die "ext/ByteLoader/byterun.h: $!";
 print BYTERUN_H $c_header, <<'EOT';
-struct bytestream {
+struct bytestream { /* XXX: not currently used - too slow */
     void *data;
     int (*pfgetc)(void *);
     int (*pfread)(char *, size_t, size_t, void *);
@@ -234,15 +239,7 @@ for ($i = 0; $i < @optype - 1; $i++) {
 printf BYTERUN_H "    OPt_%s\t\t/* %d */\n};\n\n", $optype[$i], $i;
 
 print BYTERUN_H <<'EOT';
-extern void byterun(pTHXo_ struct bytestream bs);
-
-#define INIT_SPECIALSV_LIST STMT_START { \
-EOT
-for ($i = 0; $i < @specialsv; $i++) {
-    print BYTERUN_H "\tPL_specialsv_list[$i] = $specialsv[$i]; \\\n";
-}
-print BYTERUN_H <<'EOT';
-    } STMT_END
+extern void byterun(pTHXo);
 EOT
 
 #
@@ -409,3 +406,6 @@ cop_warnings        cCOP->cop_warnings                      svindex
 main_start     PL_main_start                           opindex
 main_root      PL_main_root                            opindex
 curpad         PL_curpad                               svindex         x
+push_begin     PL_beginav                              svindex         x
+push_init      PL_initav                               svindex         x
+push_end       PL_endav                                svindex         x

diff --git a/ext/B/B.pm b/ext/B/B.pm
index 4512d91..50364fa 100644 (file)
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -9,11 +9,12 @@ package B;
 use XSLoader ();
 require Exporter;
 @ISA = qw(Exporter);
-@EXPORT_OK = qw(minus_c ppname
+@EXPORT_OK = qw(minus_c ppname save_BEGINs
                class peekop cast_I32 cstring cchar hash threadsv_names
                main_root main_start main_cv svref_2object opnumber amagic_generation
                walkoptree walkoptree_slow walkoptree_exec walksymtable
-               parents comppadlist sv_undef compile_stats timing_info init_av);
+               parents comppadlist sv_undef compile_stats timing_info
+               begin_av init_av end_av);
 sub OPf_KIDS ();
 use strict;
 @B::SV::ISA = 'B::OBJECT';

diff --git a/ext/B/B.xs b/ext/B/B.xs
index 9e29855..df5267e 100644 (file)
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -81,7 +81,7 @@ static char *opclassnames[] = {
 
 static int walkoptree_debug = 0;       /* Flag for walkoptree debug hook */
 
-static SV *specialsv_list[4];
+static SV *specialsv_list[6];
 
 static opclass
 cc_opclass(pTHX_ OP *o)
@@ -386,11 +386,15 @@ BOOT:
     specialsv_list[1] = &PL_sv_undef;
     specialsv_list[2] = &PL_sv_yes;
     specialsv_list[3] = &PL_sv_no;
+    specialsv_list[4] = pWARN_ALL;
+    specialsv_list[5] = pWARN_NONE;
 #include "defsubs.h"
 }
 
 #define B_main_cv()    PL_main_cv
 #define B_init_av()    PL_initav
+#define B_begin_av()   PL_beginav_save
+#define B_end_av()     PL_endav
 #define B_main_root()  PL_main_root
 #define B_main_start() PL_main_start
 #define B_amagic_generation()  PL_amagic_generation
@@ -402,6 +406,10 @@ BOOT:
 B::AV
 B_init_av()
 
+B::AV
+B_begin_av()
+B::AV
+B_end_av()
 B::CV
 B_main_cv()
 
@@ -515,6 +523,10 @@ minus_c()
     CODE:
        PL_minus_c = TRUE;
 
+void
+save_BEGINs()
+    CODE:
+       PL_minus_c |= 0x10;
 SV *
 cstring(sv)
        SV *    sv
@@ -693,8 +705,8 @@ PMOP_precomp(o)
        if (rx)
            sv_setpvn(ST(0), rx->precomp, rx->prelen);
 
-#define SVOP_sv(o)     cSVOPo->op_sv
-#define SVOP_gv(o)     ((GV*)cSVOPo->op_sv)
+#define SVOP_sv(o)     cSVOPo_sv
+#define SVOP_gv(o)     cGVOPo_gv
 
 MODULE = B     PACKAGE = B::SVOP               PREFIX = SVOP_
 

diff --git a/ext/B/B/Assembler.pm b/ext/B/B/Assembler.pm
index 6c51a9a..1324f7c 100644 (file)
--- a/ext/B/B/Assembler.pm
+++ b/ext/B/B/Assembler.pm
@@ -8,10 +8,11 @@ package B::Assembler;
 use Exporter;
 use B qw(ppname);
 use B::Asmdata qw(%insn_data @insn_name);
+use Config qw(%Config);
 
 @ISA = qw(Exporter);
 @EXPORT_OK = qw(assemble_fh assemble_insn strip_comments
-               parse_statement uncstring);
+               parse_statement uncstring gen_header);
 
 use strict;
 my %opnumber;
@@ -49,11 +50,12 @@ sub B::Asmdata::PUT_U8 {
     return $c;
 }
 
-sub B::Asmdata::PUT_U16 { pack("n", $_[0]) }
-sub B::Asmdata::PUT_U32 { pack("N", $_[0]) }
-sub B::Asmdata::PUT_I32 { pack("N", $_[0]) }
-sub B::Asmdata::PUT_NV  { sprintf("%lf\0", $_[0]) }
-sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here
+sub B::Asmdata::PUT_U16 { pack("S", $_[0]) }
+sub B::Asmdata::PUT_U32 { pack("L", $_[0]) }
+sub B::Asmdata::PUT_I32 { pack("L", $_[0]) }
+sub B::Asmdata::PUT_NV  { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
+                                                  # may not even be portable between compilers
+sub B::Asmdata::PUT_objindex { pack("L", $_[0]) } # could allow names here
 sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
 sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
 
@@ -79,7 +81,7 @@ sub B::Asmdata::PUT_PV {
     my $arg = shift;
     $arg = uncstring($arg);
     error "bad string argument: $arg" unless defined($arg);
-    return pack("N", length($arg)) . $arg;
+    return pack("L", length($arg)) . $arg;
 }
 sub B::Asmdata::PUT_comment_t {
     my $arg = shift;
@@ -90,7 +92,7 @@ sub B::Asmdata::PUT_comment_t {
     }
     return $arg . "\n";
 }
-sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) }
+sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
 sub B::Asmdata::PUT_none {
     my $arg = shift;
     error "extraneous argument: $arg" if defined $arg;
@@ -103,12 +105,12 @@ sub B::Asmdata::PUT_op_tr_array {
        error "wrong number of arguments to op_tr_array";
        @ary = (0) x 256;
     }
-    return pack("n256", @ary);
+    return pack("S256", @ary);
 }
 # XXX Check this works
 sub B::Asmdata::PUT_IV64 {
     my $arg = shift;
-    return pack("NN", $arg >> 32, $arg & 0xffffffff);
+    return pack("LL", $arg >> 32, $arg & 0xffffffff);
 }
 
 my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
@@ -138,6 +140,16 @@ sub strip_comments {
     return $stmt;
 }
 
+sub gen_header { # create the ByteCode header
+    my $header = B::Asmdata::PUT_U32(0x43424c50);      # 'PLBC'
+    $header .= B::Asmdata::PUT_strconst($Config{archname});
+    $header .= B::Asmdata::PUT_U32($Config{ivsize});
+    $header .= B::Asmdata::PUT_U32($Config{nvsize});
+    $header .= B::Asmdata::PUT_U32($Config{ptrsize});
+    $header .= B::Asmdata::PUT_strconst($Config{byteorder});   # PV not U32 because
+                                                               # of varying size
+    $header;
+}
 sub parse_statement {
     my $stmt = shift;
     my ($insn, $arg) = $stmt =~ m{
@@ -186,6 +198,7 @@ sub assemble_fh {
     my ($line, $insn, $arg);
     $linenum = 0;
     $errors = 0;
+    &$out(gen_header());
     while ($line = <$fh>) {
        $linenum++;
        chomp $line;

diff --git a/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm
index 941a818..8cb60ee 100644 (file)
--- a/ext/B/B/Bytecode.pm
+++ b/ext/B/B/Bytecode.pm
@@ -7,12 +7,14 @@
 #
 package B::Bytecode;
 use strict;
-use Carp;
 use IO::File;
 
-use B qw(minus_c main_cv main_root main_start comppadlist
+use B qw(main_cv main_root main_start comppadlist
         class peekop walkoptree svref_2object cstring walksymtable
-        SVf_POK SVp_POK SVf_IOK SVp_IOK
+        init_av begin_av end_av
+        SVf_POK SVp_POK SVf_IOK SVp_IOK SVf_NOK SVp_NOK
+        SVf_READONLY GVf_IMPORTED_AV GVf_IMPORTED_CV GVf_IMPORTED_HV
+        GVf_IMPORTED_SV
        );
 use B::Asmdata qw(@optype @specialsv_name);
 use B::Assembler qw(assemble_fh);
@@ -31,9 +33,16 @@ sub POK () { SVf_POK|SVp_POK }
 # XXX Shouldn't be hardwired
 sub IOK () { SVf_IOK|SVp_IOK }
 
+# Following is SVf_NOK|SVp_NOK
+# XXX Shouldn't be hardwired
+sub NOK () { SVf_NOK|SVp_NOK }
+# nonexistant flags (see B::GV::bytecode for usage)
+sub GVf_IMPORTED_IO () { 0; }
+sub GVf_IMPORTED_FORM () { 0; }
 my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv);
 my $assembler_pid;
 
+my @packages;  # list of packages to compile
 # Optimisation options. On the command line, use hyphens instead of
 # underscores for compatibility with gcc-style options. We use
 # underscores here because they are OK in (strict) barewords.
@@ -100,6 +109,11 @@ sub pvstring {
     }
 }
 
+sub nv {
+    # print full precision
+    my $str = sprintf "%.40f", $_[0];
+    return $str;
+}
 sub saved { $saved{${$_[0]}} }
 sub mark_saved { $saved{${$_[0]}} = 1 }
 sub unmark_saved { $saved{${$_[0]}} = 0 }
@@ -166,7 +180,8 @@ sub B::OP::newix {
     my ($op, $ix) = @_;
     my $class = class($op);
     my $typenum = $optype_enum{$class};
-    croak "OP::newix: can't understand class $class" unless defined($typenum);
+    require('Carp.pm'), Carp::croak("OP::newix: can't understand class $class")
+        unless defined($typenum);
     print "newop $typenum\t# $class\n";
     stop($ix);
 }
@@ -180,7 +195,7 @@ sub B::OP::bytecode {
     my $op = shift;
     my $next = $op->next;
     my $nextix;
-    my $sibix = $op->sibling->objix;
+    my $sibix = $op->sibling->objix unless $strip_syntree;
     my $ix = $op->objix;
     my $type = $op->type;
 
@@ -203,7 +218,7 @@ sub B::OP::bytecode {
 
 sub B::UNOP::bytecode {
     my $op = shift;
-    my $firstix = $op->first->objix;
+    my $firstix = $op->first->objix unless $strip_syntree;
     $op->B::OP::bytecode;
     if (($op->type || !$compress_nullops) && !$strip_syntree) {
        print "op_first $firstix\n";
@@ -251,7 +266,7 @@ sub B::PVOP::bytecode {
 
 sub B::BINOP::bytecode {
     my $op = shift;
-    my $lastix = $op->last->objix;
+    my $lastix = $op->last->objix unless $strip_syntree;
     $op->B::UNOP::bytecode;
     if (($op->type || !$compress_nullops) && !$strip_syntree) {
        print "op_last $lastix\n";
@@ -260,7 +275,7 @@ sub B::BINOP::bytecode {
 
 sub B::LISTOP::bytecode {
     my $op = shift;
-    my $children = $op->children;
+    my $children = $op->children unless $strip_syntree;
     $op->B::BINOP::bytecode;
     if (($op->type || !$compress_nullops) && !$strip_syntree) {
        print "op_children $children\n";
@@ -278,14 +293,16 @@ sub B::LOOP::bytecode {
 
 sub B::COP::bytecode {
     my $op = shift;
-    my $stashpv = $op->stashpv;
     my $file = $op->file;
     my $line = $op->line;
-    my $warnings = $op->warnings;
-    my $warningsix = $warnings->objix;
-    if ($debug_bc) {
+    if ($debug_bc) { # do this early to aid debugging
        printf "# line %s:%d\n", $file, $line;
     }
+    my $stashpv = $op->stashpv;
+    my $warnings = $op->warnings;
+    my $warningsix;
+    $warningsix = $warnings->objix;
+    $warnings->bytecode;
     $op->B::OP::bytecode;
     printf <<"EOT", pvstring($op->label), pvstring($stashpv), $op->cop_seq, pvstring($file), $op->arybase;
 newpv %s
@@ -359,14 +376,14 @@ sub B::IV::bytecode {
     return if saved($sv);
     my $iv = $sv->IVX;
     $sv->B::SV::bytecode;
-    printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
+    printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32" if $sv->FLAGS & IOK; # could be PVNV
 }
 
 sub B::NV::bytecode {
     my $sv = shift;
     return if saved($sv);
     $sv->B::SV::bytecode;
-    printf "xnv %s\n", $sv->NVX;
+    printf "xnv %s\n", nv($sv->NVX);
 }
 
 sub B::RV::bytecode {
@@ -404,7 +421,7 @@ sub B::PVNV::bytecode {
     } else {
        my $pv = $sv->PV;
        $sv->B::IV::bytecode;
-       printf "xnv %s\n", $sv->NVX;
+       printf "xnv %s\n", nv($sv->NVX);
        if ($flag == 1) {
            $pv .= "\0" . $sv->TABLE;
            printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257;
@@ -461,6 +478,7 @@ sub B::BM::bytecode {
 sub B::GV::bytecode {
     my $gv = shift;
     return if saved($gv);
+    return unless grep { $_ eq $gv->STASH->NAME; } @packages;
     my $ix = $gv->objix;
     mark_saved($gv);
     ldsv($ix);
@@ -488,6 +506,10 @@ EOT
        if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
            my $i;
            my @subfield_names = qw(SV AV HV CV FORM IO);
+           @subfield_names = grep {;
+                                       no strict 'refs';
+                                       !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->());
+                               } @subfield_names;
            my @subfields = map($gv->$_(), @subfield_names);
            my @ixes = map($_->objix, @subfields);
            # Reset sv register for $gv
@@ -510,6 +532,7 @@ sub B::HV::bytecode {
     mark_saved($hv);
     my $name = $hv->NAME;
     my $ix = $hv->objix;
+    printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS;
     if (!$name) {
        # It's an ordinary HV. Stashes have NAME set and need no further
        # saving beyond the gv_stashpv that $hv->objix already ensures.
@@ -526,7 +549,6 @@ sub B::HV::bytecode {
            printf("newpv %s\nhv_store %d\n",
                   pvstring($contents[$i]), $ixes[$i / 2]);
        }
-       printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS;
     }
 }
 
@@ -551,6 +573,7 @@ sub B::AV::bytecode {
     # create an AV with NEWSV and SvUPGRADE rather than doing newAV
     # which is what sets AvMAX and AvFILL.
     ldsv($ix);
+    printf "sv_flags 0x%x\n", $av->FLAGS & ~SVf_READONLY; # SvREADONLY_off($av) in case PADCONST
     printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS;
     if ($fill > -1) {
        my $elix;
@@ -562,11 +585,13 @@ sub B::AV::bytecode {
            print "av_extend $max\n";
        }
     }
+    printf "sv_flags 0x%x\n", $av->FLAGS; # restore flags from above
 }
 
 sub B::CV::bytecode {
     my $cv = shift;
     return if saved($cv);
+    return if ${$cv->GV} && ($cv->GV->GvFLAGS & GVf_IMPORTED_CV);
     my $ix = $cv->objix;
     $cv->B::PVMG::bytecode;
     my $i;
@@ -628,8 +653,7 @@ sub B::SPECIAL::bytecode {
 }
 
 sub bytecompile_object {
-    my $sv;
-    foreach $sv (@_) {
+    for my $sv (@_) {
        svref_2object($sv)->bytecode;
     }
 }
@@ -646,30 +670,64 @@ sub B::GV::bytecodecv {
     }
 }
 
+sub save_call_queues {
+    if (ref(begin_av()) eq "B::AV") {  # this is just to save 'use Foo;' calls
+       for my $cv (begin_av->ARRAY) {
+           my $name = $cv->STASH->NAME;
+           next unless grep { $_ eq $name } @packages;
+           my $op = $cv->START;
+           $op = $op->next while ($$op && ref $op ne "B::UNOP");
+           if ($$op && $op->name eq 'require') { # should be first UNOP
+               $cv->bytecode;
+               printf "push_begin %d\n", $cv->objix;
+           }
+       }
+    }
+    if (ref(init_av()) eq "B::AV") {
+       for my $cv (init_av->ARRAY) {
+           next unless grep { $_ eq $cv->STASH->NAME } @packages;
+           $cv->bytecode;
+           printf "push_init %d\n", $cv->objix;
+       }
+    }
+    if (ref(end_av()) eq "B::AV") {
+       for my $cv (end_av->ARRAY) {
+           next unless grep { $_ eq $cv->STASH->NAME } @packages;
+           $cv->bytecode;
+           printf "push_end %d\n", $cv->objix;
+       }
+    }
+}
+
+sub symwalk {
+     no strict 'refs';
+     my $ok = 1 if grep { (my $name = $_[0]) =~ s/::$//; $_ eq $name;} @packages;
+    if (grep { /^$_[0]/; } @packages) {
+       walksymtable(\%{"$_[0]"}, "bytecodecv", \&symwalk, $_[0]);
+    }
+    warn "considering $_[0] ... " . ($ok ? "accepted\n" : "rejected\n")
+       if $debug_bc;
+    $ok;
+}
+
 sub bytecompile_main {
     my $curpad = (comppadlist->ARRAY)[1];
     my $curpadix = $curpad->objix;
     $curpad->bytecode;
-    walkoptree(main_root, "bytecode");
+    walkoptree(main_root, "bytecode") unless ref(main_root) eq "B::NULL";
     warn "done main program, now walking symbol table\n" if $debug_bc;
-    my ($pack, %exclude);
-    foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS strict vars
-                     FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol warnings
-                     attributes File::Spec SelectSaver blib Cwd))
-    {
-       $exclude{$pack."::"} = 1;
-    }
-    no strict qw(vars refs);
-    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;
-       printf "curpad $curpadix\n";
-       # XXX Do min_intro_pending and max_intro_pending matter?
+    if (@packages) {
+       no strict qw(refs);
+       our %packages;
+       walksymtable(\%{"main::"}, "bytecodecv", \&symwalk);
+    } else {
+       die "No packages requested for compilation!\n";
     }
+    save_call_queues;
+    printf "main_root %d\n", main_root->objix;
+    printf "main_start %d\n", main_start->objix;
+    printf "curpad $curpadix\n";
+    # XXX Do min_intro_pending and max_intro_pending matter?
 }
 
 sub prepare_assemble {
@@ -727,7 +785,7 @@ sub compile {
            }
        } elsif ($opt eq "v") {
            $verbose = 1;
-       } elsif ($opt eq "m") {
+       } elsif ($opt eq "m") { # XXX: NOP
            $module_only = 1;
        } elsif ($opt eq "S") {
            $no_assemble = 1;
@@ -757,9 +815,16 @@ sub compile {
                $compress_nullops = 1;
                $omit_seq = 1;
            }
+       } elsif ($opt eq "P") {
+           $arg ||= shift @options;
+           push @packages, $arg;
        }
     }
-    if (@options) {
+    if (! @packages) {
+       warn "No package specified for compilation, assuming main::\n";
+       @packages = qw(main);
+    }
+    if (@options) { # XXX: unsupported and untested!
        return sub {
            my $objname;
            my $newfh; 
@@ -887,33 +952,33 @@ Prints each CV taken from the final symbol tree walk.
 Output (bytecode) assembler source rather than piping it
 through the assembler and outputting bytecode.
 
-=item B<-m>
-
-Compile as a module rather than a standalone program. Currently this
-just means that the bytecodes for initialising C<main_start>,
-C<main_root> and C<curpad> are omitted.
-
+=item B<-Ppackage>
+  
+Stores package in the output.
+  
 =back
 
 =head1 EXAMPLES
 
-    perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
+    perl -MO=Bytecode,-O6,-ofoo.plc,-Pmain foo.pl
 
-    perl -MO=Bytecode,-S foo.pl > foo.S
+    perl -MO=Bytecode,-S,-Pmain foo.pl > foo.S
     assemble foo.S > foo.plc
 
 Note that C<assemble> lives in the C<B> subdirectory of your perl
 library directory. The utility called perlcc may also be used to 
 help make use of this compiler.
 
-    perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
+    perl -MO=Bytecode,-PFoo,-oFoo.pmc Foo.pm
 
 =head1 BUGS
 
-Plenty. Current status: experimental.
+Output is still huge and there are still occasional crashes during
+either compilation or ByteLoading. Current status: experimental.
 
-=head1 AUTHOR
+=head1 AUTHORS
 
 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+Benjamin Stuhl, C<sho_pi@hotmail.com>
 
 =cut

diff --git a/ext/B/O.pm b/ext/B/O.pm
index 352f8d4..98fdcf6 100644 (file)
--- a/ext/B/O.pm
+++ b/ext/B/O.pm
@@ -11,6 +11,7 @@ sub import {
     my $compilesub = &{"B::${backend}::compile"}(@options);
     if (ref($compilesub) eq "CODE") {
        minus_c;
+       save_BEGINs;
        eval 'CHECK { &$compilesub() }';
     } else {
        die $compilesub;

diff --git a/ext/ByteLoader/ByteLoader.xs b/ext/ByteLoader/ByteLoader.xs
index 7c3746b..cfabf33 100644 (file)
--- a/ext/ByteLoader/ByteLoader.xs
+++ b/ext/ByteLoader/ByteLoader.xs
@@ -4,47 +4,14 @@
 #include "XSUB.h"
 #include "byterun.h"
 
-static int
-xgetc(PerlIO *io)
-{
-    dTHX;
-    return PerlIO_getc(io);
-}
-
-static int
-xfread(char *buf, size_t size, size_t n, PerlIO *io)
-{
-    dTHX;
-    int i = PerlIO_read(io, buf, n * size);
-    if (i > 0)
-       i /= size;
-    return i;
-}
-
-static void
-freadpv(U32 len, void *data, XPV *pv)
-{
-    dTHX;
-    New(666, pv->xpv_pv, len, char);
-    PerlIO_read((PerlIO*)data, (void*)pv->xpv_pv, len);
-    pv->xpv_len = len;
-    pv->xpv_cur = len - 1;
-}
-
 static I32
 byteloader_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
 {
     dTHR;
     OP *saveroot = PL_main_root;
     OP *savestart = PL_main_start;
-    struct bytestream bs;
-
-    bs.data = PL_rsfp;
-    bs.pfgetc = (int(*) (void*))xgetc;
-    bs.pfread = (int(*) (char*,size_t,size_t,void*))xfread;
-    bs.pfreadpv = freadpv;
 
-    byterun(aTHXo_ bs);
+    byterun(aTHXo);
 
     if (PL_in_eval) {
         OP *o;

diff --git a/intrpvar.h b/intrpvar.h
index 8ed93f8..d7e4025 100644 (file)
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -443,5 +443,6 @@ PERLVAR(IProc,              struct IPerlProc*)
 #if defined(USE_ITHREADS)
 PERLVAR(Iptr_table,    PTR_TBL_t*)
 #endif
+PERLVARI(Ibeginav_save, AV*, Nullav)   /* save BEGIN{}s when compiling */
 
 PERLVAR(Inullstash,    HV *)           /* illegal symbols end up here */

diff --git a/perl.c b/perl.c
index 4e0e1e1..b40e617 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -3667,7 +3667,14 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
 
     while (AvFILL(paramList) >= 0) {
        cv = (CV*)av_shift(paramList);
-       SAVEFREESV(cv);
+       if ((PL_minus_c & 0x10) && (paramList == PL_beginav)) {
+               /* save PL_beginav for compiler */
+           if (! PL_beginav_save)
+               PL_beginav_save = newAV();
+           av_push(PL_beginav_save, (SV*)cv);
+       } else {
+           SAVEFREESV(cv);
+       }
 #ifdef PERL_FLEXIBLE_EXCEPTIONS
        CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
 #else