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