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