# Copyright (c) 2003 Enache Adrian. All rights reserved.
# This module is free software; you can redistribute and/or modify
# it under the same terms as Perl itself.
# Based on the original Bytecode.pm module written by Malcolm Beattie.
our $VERSION = '1.01_01';
use B
qw(class main_cv main_root main_start cstring comppadlist
defstash curstash begin_av init_av end_av inc_gv warnhook diehook
dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
use B
::Asmdata
qw(@specialsv_name);
use B::Assembler qw(asm newasm endasm);
#################################################
my ($varix, $opix, $savebegins, %walked, %files, @cloop);
my $ithreads = $Config{'useithreads'} eq 'define';
sub ITHREADS
() { $ithreads }
#################################################
defined($pv) ? cstring
($pv."\0") : "\"\"";
my $str = pvstring
shift;
defined($ix) ?
$ix : do {
asm
"stpv", $strtab{$str} = $tix;
defined($ix) ?
$ix : do {
nice
"[".$op->name." $tix]";
asm
"newopx", $op->size | $op->type <<7;
$optab{$$op} = $opix = $ix = $tix++;
my $ix = $spectab{$$spec};
defined($ix) ?
$ix : do {
nice
'['.$specialsv_name[$$spec].']';
$spectab{$$spec} = $varix = $tix++;
defined($ix) ?
$ix : do {
asm
"newsvx", $sv->FLAGS;
$svtab{$$sv} = $varix = $ix = $tix++;
defined($ix) ?
$ix : do {
my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
my $name = $gv->STASH->NAME . "::" . $gv->NAME;
asm
"gv_fetchpvx", cstring
$name;
$svtab{$$gv} = $varix = $ix = $tix++;
asm
"sv_flags", $gv->FLAGS;
asm
"sv_refcnt", $gv->REFCNT;
asm
"xgv_flags", $gv->GvFLAGS;
asm
"gp_refcnt", $gv->GvREFCNT;
asm
"load_glob", $ix if $name eq "CORE::GLOBAL::glob";
unless $desired || desired
$gv;
$cvix = $$cv && defined $files{$cv->FILE} ?
$cv->ix : 0;
$formix = $$form && defined $files{$form->FILE} ?
$form->ix : 0;
$ioix = $name !~ /STDOUT$/ ?
$gv->IO->ix : 0;
asm
"ldsv", $varix = $ix unless $ix == $varix;
asm
"gp_cvgen", $gv->CVGEN;
asm
"gp_file", pvix
$gv->FILE;
asm
"gp_line", $gv->LINE;
asm
"formfeed", $svix if $name eq "main::\cL";
asm
"newsvx", $gv->FLAGS;
$svtab{$$gv} = $varix = $ix = $tix++;
my $stashix = $gv->STASH->ix;
$gv->B::PVMG
::bsave
($ix);
asm
"xgv_flags", $gv->GvFLAGS;
asm
"xgv_stash", $stashix;
defined($ix) ?
$ix : do {
asm
"gv_stashpvx", cstring
$name;
asm
"sv_flags", $hv->FLAGS;
$svtab{$$hv} = $varix = $ix = $tix++;
asm
"xhv_name", pvix
$name;
# my $pmrootix = $hv->PMROOT->ix; # XXX
asm
"ldsv", $varix = $ix unless $ix == $varix;
# asm "xhv_pmroot", $pmrootix; # XXX
asm
"newsvx", $hv->FLAGS;
$svtab{$$hv} = $varix = $ix = $tix++;
my $stashix = $hv->SvSTASH->ix;
for (@array = $hv->ARRAY) {
asm
"ldsv", $varix = $ix unless $ix == $varix;
($i = not $i) ? asm
("newpv", pvstring
$_) : asm
("hv_store", $_)
asm
"xmg_stash", $stashix;
asm
"xhv_riter", $hv->RITER;
asm
"sv_refcnt", $hv->REFCNT;
$$sv ?
$sv->B::SV
::ix
: 0;
sub B
::NULL
::opwalk
{ 0 }
#################################################
asm
"ldsv", $varix = $ix unless $ix == $varix;
asm
"sv_refcnt", $sv->REFCNT;
*B
::SV
::bsave
= *B
::NULL
::bsave
;
$sv->B::NULL
::bsave
($ix);
$sv->B::NULL
::bsave
($ix);
asm
"newpv", pvstring
$sv->PVBM;
$sv->B::NULL
::bsave
($ix);
$sv->B::NULL
::bsave
($ix);
asm
"xnv", sprintf "%.40g", $sv->NVX;
$sv->B::NULL
::bsave
($ix);
# See note below in B::PVNV::bsave
return if $sv->isa('B::AV');
return if $sv->isa('B::HV');
asm
"xiv", !ITHREADS
&& $sv->FLAGS & (SVf_FAKE
|SVf_READONLY
) ?
$sv->B::PVIV
::bsave
($ix);
# Magical AVs end up here, but AVs now don't have an NV slot actually
# allocated. Hence don't write out assembly to store the NV slot if
# we're actually an array.
return if $sv->isa('B::AV');
# Likewise HVs have no NV slot actually allocated.
# I don't think that they can get here, but better safe than sorry
return if $sv->isa('B::HV');
asm
"xnv", sprintf "%.40g", $sv->NVX;
push @namix, $_->PTR->ix if $_->LENGTH == B
::HEf_SVKEY
;
asm
"ldsv", $varix = $ix unless $ix == $varix;
asm
"sv_magic", cstring
$_->TYPE;
asm
"mg_obj", shift @mgix;
if ($length == B
::HEf_SVKEY
) {
asm
"mg_namex", shift @namix;
asm
"newpv", pvstring
$_->PTR;
my $stashix = $sv->SvSTASH->ix;
$sv->B::PVNV
::bsave
($ix);
asm
"xmg_stash", $stashix;
$sv->domagic($ix) if $sv->MAGICAL;
my $targix = $sv->TARG->ix;
$sv->B::PVMG
::bsave
($ix);
asm
"xlv_targoff", $sv->TARGOFF;
asm
"xlv_targlen", $sv->TARGLEN;
asm
"xlv_type", $sv->TYPE;
$sv->B::PVMG
::bsave
($ix);
asm
"xbm_useful", $sv->USEFUL;
asm
"xbm_previous", $sv->PREVIOUS;
asm
"xbm_rare", $sv->RARE;
my $topix = $io->TOP_GV->ix;
my $fmtix = $io->FMT_GV->ix;
my $bottomix = $io->BOTTOM_GV->ix;
$io->B::PVMG
::bsave
($ix);
asm
"xio_lines", $io->LINES;
asm
"xio_page", $io->PAGE;
asm
"xio_page_len", $io->PAGE_LEN;
asm
"xio_lines_left", $io->LINES_LEFT;
asm
"xio_top_name", pvix
$io->TOP_NAME;
asm
"xio_top_gv", $topix;
asm
"xio_fmt_name", pvix
$io->FMT_NAME;
asm
"xio_fmt_gv", $fmtix;
asm
"xio_bottom_name", pvix
$io->BOTTOM_NAME;
asm
"xio_bottom_gv", $bottomix;
asm
"xio_subprocess", $io->SUBPROCESS;
asm
"xio_type", ord $io->IoTYPE;
# asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX
my $stashix = $cv->STASH->ix;
my $padlistix = $cv->PADLIST->ix;
my $outsideix = $cv->OUTSIDE->ix;
my $constix = $cv->CONST ?
$cv->XSUBANY->ix : 0;
my $startix = $cv->START->opwalk;
my $rootix = $cv->ROOT->ix;
$cv->B::PVMG
::bsave
($ix);
asm
"xcv_stash", $stashix;
asm
"xcv_start", $startix;
asm
"xcv_xsubany", $constix;
asm
"xcv_file", pvix
$cv->FILE if $cv->FILE; # XXX AD
asm
"xcv_padlist", $padlistix;
asm
"xcv_outside", $outsideix;
asm
"xcv_flags", $cv->CvFLAGS;
asm
"xcv_outside_seq", $cv->OUTSIDE_SEQ;
asm
"xcv_depth", $cv->DEPTH;
$form->B::CV
::bsave
($ix);
asm
"xfm_lines", $form->LINES;
return $av->B::PVMG
::bsave
($ix) if $av->MAGICAL;
my $stashix = $av->SvSTASH->ix;
asm
"ldsv", $varix = $ix unless $ix == $varix;
asm
"av_extend", $av->MAX if $av->MAX >= 0;
asm
"av_pushx", $_ for @array;
asm
"sv_refcnt", $av->REFCNT;
asm
"xav_flags", $av->AvFLAGS;
asm
"xmg_stash", $stashix;
$files{$gv->FILE} && $gv->LINE
|| ${$cv = $gv->CV} && $files{$cv->FILE}
|| ${$form = $gv->FORM} && $files{$form->FILE}
return if $walked{$$hv}++;
while (my($k,$v) = each %stash) {
if ($v->SvTYPE == SVt_PVGV
) {
if ($$hash && $hash->NAME) {
asm
"gv_fetchpvx", cstring
$hv->NAME . "::$k";
$svtab{$$v} = $varix = $tix;
asm
"sv_flags", $v->FLAGS;
######################################################
my $nextix = $optab{$$next};
$nextix = 0, push @cloop, $op unless defined $nextix;
asm
"op_targ", $op->targ if $op->type; # tricky
asm
"op_flags", $op->flags;
asm
"op_private", $op->private;
*B
::OP
::bsave
= *B
::OP
::bsave_thin
;
|| (!ITHREADS
&& $name eq 'regcomp')
# trick for /$a/o in pp_regcomp
&& $op->private & OPpLVAL_INTRO
# change #18774 made my life hard
asm
"op_first", $firstix;
if ($op->name eq 'aassign' && $op->private & B
::OPpASSIGN_HASH
()) {
local *B
::OP
::bsave
= *B
::OP
::bsave_fat
;
local *B
::UNOP
::bsave
= *B
::UNOP
::bsave_fat
;
asm
"ldop", $lastix unless $lastix == $opix;
asm
"op_targ", $last->targ;
# not needed if no pseudohashes
*B
::BINOP
::bsave
= *B
::OP
::bsave
if VERSION
>= 5.009;
# deal with sort / formline
sub blocksort
() { OPf_SPECIAL
|OPf_STACKED
}
if ($name eq 'sort' && ($op->flags & blocksort
) == blocksort
) {
my $pushmark = $first->sibling;
my $rvgv = $pushmark->first;
my $leave = $rvgv->first;
my $leaveix = $leave->ix;
asm
"ldop", $rvgvix unless $rvgvix == $opix;
asm
"op_first", $leaveix;
my $pushmarkix = $pushmark->ix;
asm
"ldop", $pushmarkix unless $pushmarkix == $opix;
my $firstix = $first->ix;
asm
"ldop", $firstix unless $firstix == $opix;
asm
"op_sibling", $pushmarkix;
asm
"op_first", $firstix;
} elsif ($name eq 'formline') {
$op->B::UNOP
::bsave_fat
($ix);
my $siblix = $op->sibling->ix;
$op->B::OP
::bsave_thin
($ix);
asm
"op_sibling", $siblix;
# asm "op_seq", -1; XXX don't allocate OPs piece by piece
my $firstix = $op->first->ix;
asm
"op_first", $firstix;
sub B
::BINOP
::bsave_fat
{
my $lastix = $op->last->ix;
if (VERSION
< 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
asm
"ldop", $lastix unless $lastix == $opix;
asm
"op_targ", $last->targ;
$op->B::UNOP
::bsave
($ix);
my $otherix = $op->other->ix;
$op->B::UNOP
::bsave
($ix);
asm
"op_other", $otherix;
my ($rrop, $rrarg, $rstart);
# my $pmnextix = $op->pmnext->ix; # XXX
if ($op->name eq 'subst') {
$rrarg = $op->pmreplroot->ix;
$rstart = $op->pmreplstart->ix;
} elsif ($op->name eq 'pushre') {
$rrop = "op_pmreplrootpo";
$rrarg = $op->pmreplroot;
$op->B::BINOP
::bsave
($ix);
asm
"op_pmstashpv", pvix
$op->pmstashpv;
$rrop = "op_pmreplrootgv";
$rrarg = $op->pmreplroot->ix;
$rstart = $op->pmreplstart->ix if $op->name eq 'subst';
my $stashix = $op->pmstash->ix;
$op->B::BINOP
::bsave
($ix);
asm
"op_pmstash", $stashix;
asm
$rrop, $rrarg if $rrop;
asm
"op_pmreplstart", $rstart if $rstart;
asm
"op_pmflags", $op->pmflags;
asm
"op_pmpermflags", $op->pmpermflags;
asm
"op_pmdynflags", $op->pmdynflags;
# asm "op_pmnext", $pmnextix; # XXX
asm
"newpv", pvstring
$op->precomp;
asm
"op_padix", $op->padix;
return unless my $pv = $op->pv;
if ($op->name eq 'trans') {
asm
"op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
asm
"newpv", pvstring
$pv;
my $nextix = $op->nextop->ix;
my $lastix = $op->lastop->ix;
my $redoix = $op->redoop->ix;
$op->B::BINOP
::bsave
($ix);
asm
"op_redoop", $redoix;
asm
"op_nextop", $nextix;
asm
"op_lastop", $lastix;
my $warnix = $cop->warnings->ix;
asm
"cop_stashpv", pvix
$cop->stashpv;
asm
"cop_file", pvix
$cop->file;
my $stashix = $cop->stash->ix;
my $fileix = $cop->filegv->ix(1);
asm
"cop_stash", $stashix;
asm
"cop_filegv", $fileix;
asm
"cop_label", pvix
$cop->label if $cop->label; # XXX AD
asm
"cop_seq", $cop->cop_seq;
asm
"cop_arybase", $cop->arybase;
asm
"cop_line", $cop->line;
asm
"cop_warnings", $warnix;
defined($ix) ?
$ix : do {
my @oplist = $op->oplist;
$ix = $_->ix while $_ = pop @oplist;
while ($_ = pop @cloop) {
asm
"op_next", $optab{${$_->next}};
#################################################
if (($av=begin_av
)->isa("B::AV")) {
next unless $_->FILE eq $0;
asm
"push_begin", $_->ix;
next unless $_->FILE eq $0;
# XXX BEGIN { goto A while 1; A: }
for (my $op = $_->START; $$op; $op = $op->next) {
next unless $op->name eq 'require' ||
# this kludge needed for tests
$op->name eq 'gv' && do {
my $gv = class($op) eq 'SVOP' ?
(($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
$$gv && $gv->NAME =~ /use_ok|plan/
asm
"push_begin", $_->ix;
if (($av=init_av
)->isa("B::AV")) {
next unless $_->FILE eq $0;
if (($av=end_av
)->isa("B::AV")) {
next unless $_->FILE eq $0;
my ($head, $scan, $T_inhinc, $keep_syn);
*B
::OP
::bsave
= *B
::OP
::bsave_fat
;
*B
::UNOP
::bsave
= *B
::UNOP
::bsave_fat
;
*B
::BINOP
::bsave
= *B
::BINOP
::bsave_fat
;
*B
::LISTOP
::bsave
= *B
::LISTOP
::bsave_fat
;
sub bwarn
{ print STDERR
"Bytecode.pm: @_\n" }
*newasm
= *endasm
= sub { };
*asm
= sub { print " @_\n" };
*nice
= sub ($) { print "\n@_\n" };
$head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
open STDOUT
, ">$1" or die "open $1: $!";
$scan = length($1) ?
$1 : $0;
# this is here for the testsuite
*B
::COP
::file
= sub { $thatfile };
bwarn
"Ignoring '$_' option";
/^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
bwarn
"keeping the syntax tree: \"goto\" op found";
bwarn
"cannot rescan '$scan'";
asm
"main_start", main_start
->opwalk;
asm
"main_root", main_root
->ix;
asm
"main_cv", main_cv
->ix;
asm
"curpad", (comppadlist
->ARRAY)[1]->ix;
asm
"signal", cstring
"__WARN__" # XXX
asm
"incav", inc_gv
->AV->ix if $T_inhinc;
asm
"incav", inc_gv
->AV->ix if $T_inhinc;
my $dh = *{defstash
->NAME."::DATA"};
B::Bytecode - Perl compiler's bytecode backend
B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
Compiles a Perl script into a bytecode format that could be loaded
later by the ByteLoader module and executed as a regular Perl script.
$ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
other files (ex. C<use Foo;>) are saved.
prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
keep the syntax tree - it is stripped by default.
put the bytecode in <outfile> instead of dumping it to STDOUT.
scan the script for C<# line ..> directives and for <goto LABEL>
expressions. When gotos are found keep the syntax tree.
C<BEGIN { goto A: while 1; A: }> won't even compile.
C<?...?> and C<reset> do not work as expected.
variables in C<(?{ ... })> constructs are not properly scoped.
scripts that use source filters will fail miserably.
There are also undocumented bugs and options.
THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
modified by Benjamin Stuhl <sho_pi@hotmail.com>.
Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.