ext/B/B/Bytecode.pm

   1 # B::Bytecode.pm
   2 # Copyright (c) 2003 Enache Adrian. All rights reserved.
   3 # This module is free software; you can redistribute and/or modify
   4 # it under the same terms as Perl itself.
   5
   6 # Based on the original Bytecode.pm module written by Malcolm Beattie.
   7
   8 package B::Bytecode;
   9
  10 our $VERSION = '1.02';
  11
  12 use strict;
  13 use Config;
  14 use B qw(class main_cv main_root main_start cstring comppadlist
  15         defstash curstash begin_av init_av end_av inc_gv warnhook diehook
  16         dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
  17         OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
  18 use B::Asmdata qw(@specialsv_name);
  19 use B::Assembler qw(asm newasm endasm);
  20
  21 #################################################
  22
  23 my ($varix, $opix, $savebegins, %walked, %files, @cloop);
  24 my %strtab = (0,0);
  25 my %svtab = (0,0);
  26 my %optab = (0,0);
  27 my %spectab = (0,0);
  28 my $tix = 1;
  29 sub asm;
  30 sub nice ($) { }
  31
  32 BEGIN {
  33     my $ithreads = $Config{'useithreads'} eq 'define';
  34     eval qq{
  35         sub ITHREADS() { $ithreads }
  36         sub VERSION() { $] }
  37     }; die $@ if $@;
  38 }
  39
  40 #################################################
  41
  42 sub pvstring {
  43     my $pv = shift;
  44     defined($pv) ? cstring ($pv."\0") : "\"\"";
  45 }
  46
  47 sub pvix {
  48     my $str = pvstring shift;
  49     my $ix = $strtab{$str};
  50     defined($ix) ? $ix : do {
  51         asm "newpv", $str;
  52         asm "stpv", $strtab{$str} = $tix;
  53         $tix++;
  54     }
  55 }
  56
  57 sub B::OP::ix {
  58     my $op = shift;
  59     my $ix = $optab{$$op};
  60     defined($ix) ? $ix : do {
  61         nice "[".$op->name." $tix]";
  62         asm "newopx", $op->size | $op->type <<7;
  63         $optab{$$op} = $opix = $ix = $tix++;
  64         $op->bsave($ix);
  65         $ix;
  66     }
  67 }
  68
  69 sub B::SPECIAL::ix {
  70     my $spec = shift;
  71     my $ix = $spectab{$$spec};
  72     defined($ix) ? $ix : do {
  73         nice '['.$specialsv_name[$$spec].']';
  74         asm "ldspecsvx", $$spec;
  75         $spectab{$$spec} = $varix = $tix++;
  76     }
  77 }
  78
  79 sub B::SV::ix {
  80     my $sv = shift;
  81     my $ix = $svtab{$$sv};
  82     defined($ix) ? $ix : do {
  83         nice '['.class($sv).']';
  84         asm "newsvx", $sv->FLAGS;
  85         $svtab{$$sv} = $varix = $ix = $tix++;
  86         $sv->bsave($ix);
  87         $ix;
  88     }
  89 }
  90
  91 sub B::GV::ix {
  92     my ($gv,$desired) = @_;
  93     my $ix = $svtab{$$gv};
  94     defined($ix) ? $ix : do {
  95         if ($gv->GP) {
  96             my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
  97             nice "[GV]";
  98             my $name = $gv->STASH->NAME . "::" . $gv->NAME;
  99             asm "gv_fetchpvx", cstring $name;
 100             $svtab{$$gv} = $varix = $ix = $tix++;
 101             asm "sv_flags", $gv->FLAGS;
 102             asm "sv_refcnt", $gv->REFCNT;
 103             asm "xgv_flags", $gv->GvFLAGS;
 104
 105             asm "gp_refcnt", $gv->GvREFCNT;
 106             asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
 107             return $ix
 108                     unless $desired || desired $gv;
 109             $svix = $gv->SV->ix;
 110             $avix = $gv->AV->ix;
 111             $hvix = $gv->HV->ix;
 112
 113     # XXX {{{{
 114             my $cv = $gv->CV;
 115             $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0;
 116             my $form = $gv->FORM;
 117             $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0;
 118
 119             $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;
 120                                                             # }}}} XXX
 121
 122             nice "-GV-",
 123             asm "ldsv", $varix = $ix unless $ix == $varix;
 124             asm "gp_sv", $svix;
 125             asm "gp_av", $avix;
 126             asm "gp_hv", $hvix;
 127             asm "gp_cv", $cvix;
 128             asm "gp_io", $ioix;
 129             asm "gp_cvgen", $gv->CVGEN;
 130             asm "gp_form", $formix;
 131             asm "gp_file", pvix $gv->FILE;
 132             asm "gp_line", $gv->LINE;
 133             asm "formfeed", $svix if $name eq "main::\cL";
 134         } else {
 135             nice "[GV]";
 136             asm "newsvx", $gv->FLAGS;
 137             $svtab{$$gv} = $varix = $ix = $tix++;
 138             my $stashix = $gv->STASH->ix;
 139             $gv->B::PVMG::bsave($ix);
 140             asm "xgv_flags", $gv->GvFLAGS;
 141             asm "xgv_stash", $stashix;
 142         }
 143         $ix;
 144     }
 145 }
 146
 147 sub B::HV::ix {
 148     my $hv = shift;
 149     my $ix = $svtab{$$hv};
 150     defined($ix) ? $ix : do {
 151         my ($ix,$i,@array);
 152         my $name = $hv->NAME;
 153         if ($name) {
 154             nice "[STASH]";
 155             asm "gv_stashpvx", cstring $name;
 156             asm "sv_flags", $hv->FLAGS;
 157             $svtab{$$hv} = $varix = $ix = $tix++;
 158             asm "xhv_name", pvix $name;
 159             # my $pmrootix = $hv->PMROOT->ix;   # XXX
 160             asm "ldsv", $varix = $ix unless $ix == $varix;
 161             # asm "xhv_pmroot", $pmrootix;      # XXX
 162         } else {
 163             nice "[HV]";
 164             asm "newsvx", $hv->FLAGS;
 165             $svtab{$$hv} = $varix = $ix = $tix++;
 166             my $stashix = $hv->SvSTASH->ix;
 167             for (@array = $hv->ARRAY) {
 168                 next if $i = not $i;
 169                 $_ = $_->ix;
 170             }
 171             nice "-HV-",
 172             asm "ldsv", $varix = $ix unless $ix == $varix;
 173             ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
 174                 for @array;
 175             if (VERSION < 5.009) {
 176                 asm "xnv", $hv->NVX;
 177             }
 178             asm "xmg_stash", $stashix;
 179             asm "xhv_riter", $hv->RITER;
 180         }
 181         asm "sv_refcnt", $hv->REFCNT;
 182         $ix;
 183     }
 184 }
 185
 186 sub B::NULL::ix {
 187     my $sv = shift;
 188     $$sv ? $sv->B::SV::ix : 0;
 189 }
 190
 191 sub B::NULL::opwalk { 0 }
 192
 193 #################################################
 194
 195 sub B::NULL::bsave {
 196     my ($sv,$ix) = @_;
 197
 198     nice '-'.class($sv).'-',
 199     asm "ldsv", $varix = $ix unless $ix == $varix;
 200     asm "sv_refcnt", $sv->REFCNT;
 201 }
 202
 203 sub B::SV::bsave;
 204     *B::SV::bsave = *B::NULL::bsave;
 205
 206 sub B::RV::bsave {
 207     my ($sv,$ix) = @_;
 208     my $rvix = $sv->RV->ix;
 209     $sv->B::NULL::bsave($ix);
 210     asm "xrv", $rvix;
 211 }
 212
 213 sub B::PV::bsave {
 214     my ($sv,$ix) = @_;
 215     $sv->B::NULL::bsave($ix);
 216     asm "newpv", pvstring $sv->PVBM;
 217     asm "xpv";
 218 }
 219
 220 sub B::IV::bsave {
 221     my ($sv,$ix) = @_;
 222     $sv->B::NULL::bsave($ix);
 223     asm "xiv", $sv->IVX;
 224 }
 225
 226 sub B::NV::bsave {
 227     my ($sv,$ix) = @_;
 228     $sv->B::NULL::bsave($ix);
 229     asm "xnv", sprintf "%.40g", $sv->NVX;
 230 }
 231
 232 sub B::PVIV::bsave {
 233     my ($sv,$ix) = @_;
 234     $sv->POK ?
 235         $sv->B::PV::bsave($ix):
 236     $sv->ROK ?
 237         $sv->B::RV::bsave($ix):
 238         $sv->B::NULL::bsave($ix);
 239     if (VERSION >= 5.009) {
 240         # See note below in B::PVNV::bsave
 241         return if $sv->isa('B::AV');
 242         return if $sv->isa('B::HV');
 243         return if $sv->isa('B::CV');
 244     }
 245     asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
 246         "0 but true" : $sv->IVX;
 247 }
 248
 249 sub B::PVNV::bsave {
 250     my ($sv,$ix) = @_;
 251     $sv->B::PVIV::bsave($ix);
 252     if (VERSION >= 5.009) {
 253         # Magical AVs end up here, but AVs now don't have an NV slot actually
 254         # allocated. Hence don't write out assembly to store the NV slot if
 255         # we're actually an array.
 256         return if $sv->isa('B::AV');
 257         # Likewise HVs have no NV slot actually allocated.
 258         # I don't think that they can get here, but better safe than sorry
 259         return if $sv->isa('B::HV');
 260         return if $sv->isa('B::CV');
 261         return if $sv->isa('B::FM');
 262      }
 263     asm "xnv", sprintf "%.40g", $sv->NVX;
 264 }
 265
 266 sub B::PVMG::domagic {
 267     my ($sv,$ix) = @_;
 268     nice '-MAGICAL-';
 269     my @mglist = $sv->MAGIC;
 270     my (@mgix, @namix);
 271     for (@mglist) {
 272         push @mgix, $_->OBJ->ix;
 273         push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
 274     }
 275
 276     nice '-'.class($sv).'-',
 277     asm "ldsv", $varix = $ix unless $ix == $varix;
 278     for (@mglist) {
 279         asm "sv_magic", cstring $_->TYPE;
 280         asm "mg_obj", shift @mgix;
 281         my $length = $_->LENGTH;
 282         if ($length == B::HEf_SVKEY) {
 283             asm "mg_namex", shift @namix;
 284         } elsif ($length) {
 285             asm "newpv", pvstring $_->PTR;
 286             asm "mg_name";
 287         }
 288     }
 289 }
 290
 291 sub B::PVMG::bsave {
 292     my ($sv,$ix) = @_;
 293     my $stashix = $sv->SvSTASH->ix;
 294     $sv->B::PVNV::bsave($ix);
 295     asm "xmg_stash", $stashix;
 296     $sv->domagic($ix) if $sv->MAGICAL;
 297 }
 298
 299 sub B::PVLV::bsave {
 300     my ($sv,$ix) = @_;
 301     my $targix = $sv->TARG->ix;
 302     $sv->B::PVMG::bsave($ix);
 303     asm "xlv_targ", $targix;
 304     asm "xlv_targoff", $sv->TARGOFF;
 305     asm "xlv_targlen", $sv->TARGLEN;
 306     asm "xlv_type", $sv->TYPE;
 307
 308 }
 309
 310 sub B::BM::bsave {
 311     my ($sv,$ix) = @_;
 312     $sv->B::PVMG::bsave($ix);
 313     asm "xpv_cur", $sv->CUR;
 314     asm "xbm_useful", $sv->USEFUL;
 315     asm "xbm_previous", $sv->PREVIOUS;
 316     asm "xbm_rare", $sv->RARE;
 317 }
 318
 319 sub B::IO::bsave {
 320     my ($io,$ix) = @_;
 321     my $topix = $io->TOP_GV->ix;
 322     my $fmtix = $io->FMT_GV->ix;
 323     my $bottomix = $io->BOTTOM_GV->ix;
 324     $io->B::PVMG::bsave($ix);
 325     asm "xio_lines", $io->LINES;
 326     asm "xio_page", $io->PAGE;
 327     asm "xio_page_len", $io->PAGE_LEN;
 328     asm "xio_lines_left", $io->LINES_LEFT;
 329     asm "xio_top_name", pvix $io->TOP_NAME;
 330     asm "xio_top_gv", $topix;
 331     asm "xio_fmt_name", pvix $io->FMT_NAME;
 332     asm "xio_fmt_gv", $fmtix;
 333     asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
 334     asm "xio_bottom_gv", $bottomix;
 335     asm "xio_subprocess", $io->SUBPROCESS;
 336     asm "xio_type", ord $io->IoTYPE;
 337     # asm "xio_flags", ord($io->IoFLAGS) & ~32;         # XXX XXX
 338 }
 339
 340 sub B::CV::bsave {
 341     my ($cv,$ix) = @_;
 342     my $stashix = $cv->STASH->ix;
 343     my $gvix = $cv->GV->ix;
 344     my $padlistix = $cv->PADLIST->ix;
 345     my $outsideix = $cv->OUTSIDE->ix;
 346     my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
 347     my $startix = $cv->START->opwalk;
 348     my $rootix = $cv->ROOT->ix;
 349
 350     $cv->B::PVMG::bsave($ix);
 351     asm "xcv_stash", $stashix;
 352     asm "xcv_start", $startix;
 353     asm "xcv_root", $rootix;
 354     asm "xcv_xsubany", $constix;
 355     asm "xcv_gv", $gvix;
 356     asm "xcv_file", pvix $cv->FILE if $cv->FILE;        # XXX AD
 357     asm "xcv_padlist", $padlistix;
 358     asm "xcv_outside", $outsideix;
 359     asm "xcv_flags", $cv->CvFLAGS;
 360     asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
 361     asm "xcv_depth", $cv->DEPTH;
 362 }
 363
 364 sub B::FM::bsave {
 365     my ($form,$ix) = @_;
 366
 367     $form->B::CV::bsave($ix);
 368     asm "xfm_lines", $form->LINES;
 369 }
 370
 371 sub B::AV::bsave {
 372     my ($av,$ix) = @_;
 373     return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
 374     my @array = $av->ARRAY;
 375     $_ = $_->ix for @array;
 376     my $stashix = $av->SvSTASH->ix;
 377
 378     nice "-AV-",
 379     asm "ldsv", $varix = $ix unless $ix == $varix;
 380     asm "av_extend", $av->MAX if $av->MAX >= 0;
 381     asm "av_pushx", $_ for @array;
 382     asm "sv_refcnt", $av->REFCNT;
 383     if (VERSION < 5.009) {
 384         asm "xav_flags", $av->AvFLAGS;
 385     }
 386     asm "xmg_stash", $stashix;
 387 }
 388
 389 sub B::GV::desired {
 390     my $gv = shift;
 391     my ($cv, $form);
 392     $files{$gv->FILE} && $gv->LINE
 393     || ${$cv = $gv->CV} && $files{$cv->FILE}
 394     || ${$form = $gv->FORM} && $files{$form->FILE}
 395 }
 396
 397 sub B::HV::bwalk {
 398     my $hv = shift;
 399     return if $walked{$$hv}++;
 400     my %stash = $hv->ARRAY;
 401     while (my($k,$v) = each %stash) {
 402         if ($v->SvTYPE == SVt_PVGV) {
 403             my $hash = $v->HV;
 404             if ($$hash && $hash->NAME) {
 405                 $hash->bwalk;
 406             }
 407             $v->ix(1) if desired $v;
 408         } else {
 409             nice "[prototype]";
 410             asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
 411             $svtab{$$v} = $varix = $tix;
 412             $v->bsave($tix++);
 413             asm "sv_flags", $v->FLAGS;
 414         }
 415     }
 416 }
 417
 418 ######################################################
 419
 420
 421 sub B::OP::bsave_thin {
 422     my ($op, $ix) = @_;
 423     my $next = $op->next;
 424     my $nextix = $optab{$$next};
 425     $nextix = 0, push @cloop, $op unless defined $nextix;
 426     if ($ix != $opix) {
 427         nice '-'.$op->name.'-',
 428         asm "ldop", $opix = $ix;
 429     }
 430     asm "op_next", $nextix;
 431     asm "op_targ", $op->targ if $op->type;              # tricky
 432     asm "op_flags", $op->flags;
 433     asm "op_private", $op->private;
 434 }
 435
 436 sub B::OP::bsave;
 437     *B::OP::bsave = *B::OP::bsave_thin;
 438
 439 sub B::UNOP::bsave {
 440     my ($op, $ix) = @_;
 441     my $name = $op->name;
 442     my $flags = $op->flags;
 443     my $first = $op->first;
 444     my $firstix =
 445         $name =~ /fl[io]p/
 446                         # that's just neat
 447     ||  (!ITHREADS && $name eq 'regcomp')
 448                         # trick for /$a/o in pp_regcomp
 449     ||  $name eq 'rv2sv'
 450             && $op->flags & OPf_MOD
 451             && $op->private & OPpLVAL_INTRO
 452                         # change #18774 made my life hard
 453     ?   $first->ix
 454     :   0;
 455
 456     $op->B::OP::bsave($ix);
 457     asm "op_first", $firstix;
 458 }
 459
 460 sub B::BINOP::bsave {
 461     my ($op, $ix) = @_;
 462     if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
 463         my $last = $op->last;
 464         my $lastix = do {
 465             local *B::OP::bsave = *B::OP::bsave_fat;
 466             local *B::UNOP::bsave = *B::UNOP::bsave_fat;
 467             $last->ix;
 468         };
 469         asm "ldop", $lastix unless $lastix == $opix;
 470         asm "op_targ", $last->targ;
 471         $op->B::OP::bsave($ix);
 472         asm "op_last", $lastix;
 473     } else {
 474         $op->B::OP::bsave($ix);
 475     }
 476 }
 477
 478 # not needed if no pseudohashes
 479
 480 *B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
 481
 482 # deal with sort / formline
 483
 484 sub B::LISTOP::bsave {
 485     my ($op, $ix) = @_;
 486     my $name = $op->name;
 487     sub blocksort() { OPf_SPECIAL|OPf_STACKED }
 488     if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
 489         my $first = $op->first;
 490         my $pushmark = $first->sibling;
 491         my $rvgv = $pushmark->first;
 492         my $leave = $rvgv->first;
 493
 494         my $leaveix = $leave->ix;
 495
 496         my $rvgvix = $rvgv->ix;
 497         asm "ldop", $rvgvix unless $rvgvix == $opix;
 498         asm "op_first", $leaveix;
 499
 500         my $pushmarkix = $pushmark->ix;
 501         asm "ldop", $pushmarkix unless $pushmarkix == $opix;
 502         asm "op_first", $rvgvix;
 503
 504         my $firstix = $first->ix;
 505         asm "ldop", $firstix unless $firstix == $opix;
 506         asm "op_sibling", $pushmarkix;
 507
 508         $op->B::OP::bsave($ix);
 509         asm "op_first", $firstix;
 510     } elsif ($name eq 'formline') {
 511         $op->B::UNOP::bsave_fat($ix);
 512     } else {
 513         $op->B::OP::bsave($ix);
 514     }
 515 }
 516
 517 # fat versions
 518
 519 sub B::OP::bsave_fat {
 520     my ($op, $ix) = @_;
 521     my $siblix = $op->sibling->ix;
 522
 523     $op->B::OP::bsave_thin($ix);
 524     asm "op_sibling", $siblix;
 525     # asm "op_seq", -1;                 XXX don't allocate OPs piece by piece
 526 }
 527
 528 sub B::UNOP::bsave_fat {
 529     my ($op,$ix) = @_;
 530     my $firstix = $op->first->ix;
 531
 532     $op->B::OP::bsave($ix);
 533     asm "op_first", $firstix;
 534 }
 535
 536 sub B::BINOP::bsave_fat {
 537     my ($op,$ix) = @_;
 538     my $last = $op->last;
 539     my $lastix = $op->last->ix;
 540     if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
 541         asm "ldop", $lastix unless $lastix == $opix;
 542         asm "op_targ", $last->targ;
 543     }
 544
 545     $op->B::UNOP::bsave($ix);
 546     asm "op_last", $lastix;
 547 }
 548
 549 sub B::LOGOP::bsave {
 550     my ($op,$ix) = @_;
 551     my $otherix = $op->other->ix;
 552
 553     $op->B::UNOP::bsave($ix);
 554     asm "op_other", $otherix;
 555 }
 556
 557 sub B::PMOP::bsave {
 558     my ($op,$ix) = @_;
 559     my ($rrop, $rrarg, $rstart);
 560
 561     # my $pmnextix = $op->pmnext->ix;   # XXX
 562
 563     if (ITHREADS) {
 564         if ($op->name eq 'subst') {
 565             $rrop = "op_pmreplroot";
 566             $rrarg = $op->pmreplroot->ix;
 567             $rstart = $op->pmreplstart->ix;
 568         } elsif ($op->name eq 'pushre') {
 569             $rrop = "op_pmreplrootpo";
 570             $rrarg = $op->pmreplroot;
 571         }
 572         $op->B::BINOP::bsave($ix);
 573         asm "op_pmstashpv", pvix $op->pmstashpv;
 574     } else {
 575         $rrop = "op_pmreplrootgv";
 576         $rrarg = $op->pmreplroot->ix;
 577         $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
 578         my $stashix = $op->pmstash->ix;
 579         $op->B::BINOP::bsave($ix);
 580         asm "op_pmstash", $stashix;
 581     }
 582
 583     asm $rrop, $rrarg if $rrop;
 584     asm "op_pmreplstart", $rstart if $rstart;
 585
 586     asm "op_pmflags", $op->pmflags;
 587     asm "op_pmpermflags", $op->pmpermflags;
 588     asm "op_pmdynflags", $op->pmdynflags;
 589     # asm "op_pmnext", $pmnextix;       # XXX
 590     asm "newpv", pvstring $op->precomp;
 591     asm "pregcomp";
 592 }
 593
 594 sub B::SVOP::bsave {
 595     my ($op,$ix) = @_;
 596     my $svix = $op->sv->ix;
 597
 598     $op->B::OP::bsave($ix);
 599     asm "op_sv", $svix;
 600 }
 601
 602 sub B::PADOP::bsave {
 603     my ($op,$ix) = @_;
 604
 605     $op->B::OP::bsave($ix);
 606     asm "op_padix", $op->padix;
 607 }
 608
 609 sub B::PVOP::bsave {
 610     my ($op,$ix) = @_;
 611     $op->B::OP::bsave($ix);
 612     return unless my $pv = $op->pv;
 613
 614     if ($op->name eq 'trans') {
 615         asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
 616     } else {
 617         asm "newpv", pvstring $pv;
 618         asm "op_pv";
 619     }
 620 }
 621
 622 sub B::LOOP::bsave {
 623     my ($op,$ix) = @_;
 624     my $nextix = $op->nextop->ix;
 625     my $lastix = $op->lastop->ix;
 626     my $redoix = $op->redoop->ix;
 627
 628     $op->B::BINOP::bsave($ix);
 629     asm "op_redoop", $redoix;
 630     asm "op_nextop", $nextix;
 631     asm "op_lastop", $lastix;
 632 }
 633
 634 sub B::COP::bsave {
 635     my ($cop,$ix) = @_;
 636     my $warnix = $cop->warnings->ix;
 637     my $ioix = $cop->io->ix;
 638     if (ITHREADS) {
 639         $cop->B::OP::bsave($ix);
 640         asm "cop_stashpv", pvix $cop->stashpv;
 641         asm "cop_file", pvix $cop->file;
 642     } else {
 643         my $stashix = $cop->stash->ix;
 644         my $fileix = $cop->filegv->ix(1);
 645         $cop->B::OP::bsave($ix);
 646         asm "cop_stash", $stashix;
 647         asm "cop_filegv", $fileix;
 648     }
 649     asm "cop_label", pvix $cop->label if $cop->label;   # XXX AD
 650     asm "cop_seq", $cop->cop_seq;
 651     asm "cop_arybase", $cop->arybase;
 652     asm "cop_line", $cop->line;
 653     asm "cop_warnings", $warnix;
 654     asm "cop_io", $ioix;
 655 }
 656
 657 sub B::OP::opwalk {
 658     my $op = shift;
 659     my $ix = $optab{$$op};
 660     defined($ix) ? $ix : do {
 661         my $ix;
 662         my @oplist = $op->oplist;
 663         push @cloop, undef;
 664         $ix = $_->ix while $_ = pop @oplist;
 665         while ($_ = pop @cloop) {
 666             asm "ldop", $optab{$$_};
 667             asm "op_next", $optab{${$_->next}};
 668         }
 669         $ix;
 670     }
 671 }
 672
 673 #################################################
 674
 675 sub save_cq {
 676     my $av;
 677     if (($av=begin_av)->isa("B::AV")) {
 678         if ($savebegins) {
 679             for ($av->ARRAY) {
 680                 next unless $_->FILE eq $0;
 681                 asm "push_begin", $_->ix;
 682             }
 683         } else {
 684             for ($av->ARRAY) {
 685                 next unless $_->FILE eq $0;
 686                 # XXX BEGIN { goto A while 1; A: }
 687                 for (my $op = $_->START; $$op; $op = $op->next) {
 688                     next unless $op->name eq 'require' ||
 689                         # this kludge needed for tests
 690                         $op->name eq 'gv' && do {
 691                             my $gv = class($op) eq 'SVOP' ?
 692                                 $op->gv :
 693                                 (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
 694                             $$gv && $gv->NAME =~ /use_ok|plan/
 695                         };
 696                     asm "push_begin", $_->ix;
 697                     last;
 698                 }
 699             }
 700         }
 701     }
 702     if (($av=init_av)->isa("B::AV")) {
 703         for ($av->ARRAY) {
 704             next unless $_->FILE eq $0;
 705             asm "push_init", $_->ix;
 706         }
 707     }
 708     if (($av=end_av)->isa("B::AV")) {
 709         for ($av->ARRAY) {
 710             next unless $_->FILE eq $0;
 711             asm "push_end", $_->ix;
 712         }
 713     }
 714 }
 715
 716 sub compile {
 717     my ($head, $scan, $T_inhinc, $keep_syn);
 718     my $cwd = '';
 719     $files{$0} = 1;
 720     sub keep_syn {
 721         $keep_syn = 1;
 722         *B::OP::bsave = *B::OP::bsave_fat;
 723         *B::UNOP::bsave = *B::UNOP::bsave_fat;
 724         *B::BINOP::bsave = *B::BINOP::bsave_fat;
 725         *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
 726     }
 727     sub bwarn { print STDERR "Bytecode.pm: @_\n" }
 728
 729     for (@_) {
 730         if (/^-S/) {
 731             *newasm = *endasm = sub { };
 732             *asm = sub { print "    @_\n" };
 733             *nice = sub ($) { print "\n@_\n" };
 734         } elsif (/^-H/) {
 735             require ByteLoader;
 736             $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
 737         } elsif (/^-k/) {
 738             keep_syn;
 739         } elsif (/^-o(.*)$/) {
 740             open STDOUT, ">$1" or die "open $1: $!";
 741         } elsif (/^-f(.*)$/) {
 742             $files{$1} = 1;
 743         } elsif (/^-s(.*)$/) {
 744             $scan = length($1) ? $1 : $0;
 745         } elsif (/^-b/) {
 746             $savebegins = 1;
 747     # this is here for the testsuite
 748         } elsif (/^-TI/) {
 749             $T_inhinc = 1;
 750         } elsif (/^-TF(.*)/) {
 751             my $thatfile = $1;
 752             *B::COP::file = sub { $thatfile };
 753         } else {
 754             bwarn "Ignoring '$_' option";
 755         }
 756     }
 757     if ($scan) {
 758         my $f;
 759         if (open $f, $scan) {
 760             while (<$f>) {
 761                 /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
 762                 /^#/ and next;
 763                 if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
 764                     bwarn "keeping the syntax tree: \"goto\" op found";
 765                     keep_syn;
 766                 }
 767             }
 768         } else {
 769             bwarn "cannot rescan '$scan'";
 770         }
 771         close $f;
 772     }
 773     binmode STDOUT;
 774     return sub {
 775         print $head if $head;
 776         newasm sub { print @_ };
 777
 778         defstash->bwalk;
 779         asm "main_start", main_start->opwalk;
 780         asm "main_root", main_root->ix;
 781         asm "main_cv", main_cv->ix;
 782         asm "curpad", (comppadlist->ARRAY)[1]->ix;
 783
 784         asm "signal", cstring "__WARN__"                # XXX
 785             if warnhook->ix;
 786         asm "incav", inc_gv->AV->ix if $T_inhinc;
 787         save_cq;
 788         asm "incav", inc_gv->AV->ix if $T_inhinc;
 789         asm "dowarn", dowarn;
 790
 791         {
 792             no strict 'refs';
 793             nice "<DATA>";
 794             my $dh = *{defstash->NAME."::DATA"};
 795             unless (eof $dh) {
 796                 local undef $/;
 797                 asm "data", ord 'D';
 798                 print <$dh>;
 799             } else {
 800                 asm "ret";
 801             }
 802         }
 803
 804         endasm;
 805     }
 806 }
 807
 808 1;
 809
 810 =head1 NAME
 811
 812 B::Bytecode - Perl compiler's bytecode backend
 813
 814 =head1 SYNOPSIS
 815
 816 B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
 817
 818 =head1 DESCRIPTION
 819
 820 Compiles a Perl script into a bytecode format that could be loaded
 821 later by the ByteLoader module and executed as a regular Perl script.
 822
 823 =head1 EXAMPLE
 824
 825     $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
 826     $ perl hi
 827     hi!
 828
 829 =head1 OPTIONS
 830
 831 =over 4
 832
 833 =item B<-b>
 834
 835 Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
 836 other files (ex. C<use Foo;>) are saved.
 837
 838 =item B<-H>
 839
 840 prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
 841
 842 =item B<-k>
 843
 844 keep the syntax tree - it is stripped by default.
 845
 846 =item B<-o>I<outfile>
 847
 848 put the bytecode in <outfile> instead of dumping it to STDOUT.
 849
 850 =item B<-s>
 851
 852 scan the script for C<# line ..> directives and for <goto LABEL>
 853 expressions. When gotos are found keep the syntax tree.
 854
 855 =back
 856
 857 =head1 KNOWN BUGS
 858
 859 =over 4
 860
 861 =item *
 862
 863 C<BEGIN { goto A: while 1; A: }> won't even compile.
 864
 865 =item *
 866
 867 C<?...?> and C<reset> do not work as expected.
 868
 869 =item *
 870
 871 variables in C<(?{ ... })> constructs are not properly scoped.
 872
 873 =item *
 874
 875 scripts that use source filters will fail miserably.
 876
 877 =back
 878
 879 =head1 NOTICE
 880
 881 There are also undocumented bugs and options.
 882
 883 THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
 884
 885 =head1 AUTHORS
 886
 887 Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
 888 modified by Benjamin Stuhl <sho_pi@hotmail.com>.
 889
 890 Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.
 891
 892 =cut