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 "newop", $op->size;
  58         asm "stop", $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 "ldspecsv", $$spec;
  70         asm "stsv", $spectab{$$spec} = $varix = $tix;
  71         $tix++;
  72     }
  73 }
  74
  75 sub B::SV::ix {
  76     my $sv = shift;
  77     my $ix = $svtab{$$sv};
  78     defined($ix) ? $ix : do {
  79         nice '['.class($sv).']';
  80         asm "newsv", $sv->SvTYPE;
  81         asm "stsv", $svtab{$$sv} = $varix = $ix = $tix++;
  82         $sv->bsave($ix);
  83         $ix;
  84     }
  85 }
  86
  87 sub B::GV::ix {
  88     my ($gv,$desired) = @_;
  89     my $ix = $svtab{$$gv};
  90     defined($ix) ? $ix : do {
  91         if ($gv->GP) {
  92             my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
  93             nice "[GV]";
  94             my $name = $gv->STASH->NAME . "::" . $gv->NAME;
  95             asm "gv_fetchpv", cstring $name;
  96             asm "stsv", $svtab{$$gv} = $varix = $ix = $tix++;
  97             asm "sv_flags", $gv->FLAGS;
  98             asm "sv_refcnt", $gv->REFCNT;
  99             asm "xgv_flags", $gv->GvFLAGS;
 100
 101             asm "gp_refcnt", $gv->GvREFCNT;
 102             asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
 103             return $ix
 104                     unless $desired || desired $gv;
 105             $svix = $gv->SV->ix;
 106             $avix = $gv->AV->ix;
 107             $hvix = $gv->HV->ix;
 108
 109     # TODO: kludge
 110             my $cv = $gv->CV;
 111             $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0;
 112             my $form = $gv->FORM;
 113             $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0;
 114
 115             $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;               # 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 "newsv", SVt_PVGV;
 132             asm "stsv", $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_stashpv", cstring $name;
 151             asm "stsv", $svtab{$$hv} = $varix = $ix = $tix++;
 152             asm "xhv_name", pvix $name;
 153             # my $pmrootix = $hv->PMROOT->ix;   # XXX
 154             asm "ldsv", $varix = $ix unless $ix == $varix;
 155             # asm "xhv_pmroot", $pmrootix;      # XXX
 156         } else {
 157             nice "[HV]";
 158             asm "newsv", SVt_PVHV;
 159             asm "stsv", $svtab{$$hv} = $varix = $ix = $tix++;
 160             my $stashix = $hv->SvSTASH->ix;
 161             for (@array = $hv->ARRAY) {
 162                 next if $i = not $i;
 163                 $_ = $_->ix;
 164             }
 165             nice "-HV-",
 166             asm "ldsv", $varix = $ix unless $ix == $varix;
 167             ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
 168                 for @array;
 169             asm "xnv", $hv->NVX;
 170             asm "xmg_stash", $stashix;
 171         }
 172         asm "sv_refcnt", $hv->REFCNT;
 173         asm "sv_flags", $hv->FLAGS;
 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     asm "sv_flags", $sv->FLAGS;
 194 }
 195
 196 sub B::SV::bsave;
 197     *B::SV::bsave = *B::NULL::bsave;
 198
 199 sub B::RV::bsave {
 200     my ($sv,$ix) = @_;
 201     my $rvix = $sv->RV->ix;
 202     $sv->B::NULL::bsave($ix);
 203     asm "xrv", $rvix;
 204 }
 205
 206 sub B::PV::bsave {
 207     my ($sv,$ix) = @_;
 208     $sv->B::NULL::bsave($ix);
 209     asm "newpv", pvstring $sv->PVBM;
 210     asm "xpv";
 211 }
 212
 213 sub B::IV::bsave {
 214     my ($sv,$ix) = @_;
 215     $sv->B::NULL::bsave($ix);
 216     asm "xiv", $sv->IVX;
 217 }
 218
 219 sub B::NV::bsave {
 220     my ($sv,$ix) = @_;
 221     $sv->B::NULL::bsave($ix);
 222     asm "xnv", sprintf "%.40g", $sv->NVX;
 223 }
 224
 225 sub B::PVIV::bsave {
 226     my ($sv,$ix) = @_;
 227     $sv->POK ?
 228         $sv->B::PV::bsave($ix):
 229     $sv->ROK ?
 230         $sv->B::RV::bsave($ix):
 231         $sv->B::NULL::bsave($ix);
 232     asm "xiv", !$ithreads && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
 233         "0 but true" : $sv->IVX;
 234 }
 235
 236 sub B::PVNV::bsave {
 237     my ($sv,$ix) = @_;
 238     $sv->B::PVIV::bsave($ix);
 239     asm "xnv", sprintf "%.40g", $sv->NVX;
 240 }
 241
 242 sub B::PVMG::domagic {
 243     my ($sv,$ix) = @_;
 244     nice '-MAGICAL-';
 245     my @mglist = $sv->MAGIC;
 246     my (@mgix, @namix);
 247     for (@mglist) {
 248         push @mgix, $_->OBJ->ix;
 249         push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
 250     }
 251
 252     nice '-'.class($sv).'-',
 253     asm "ldsv", $varix = $ix unless $ix == $varix;
 254     for (@mglist) {
 255         asm "sv_magic", cstring $_->TYPE;
 256         asm "mg_obj", shift @mgix;
 257         my $length = $_->LENGTH;
 258         if ($length == B::HEf_SVKEY) {
 259             asm "mg_namex", shift @namix;
 260         } elsif ($length) {
 261             asm "newpv", pvstring $_->PTR;
 262             asm "mg_name";
 263         }
 264     }
 265 }
 266
 267 sub B::PVMG::bsave {
 268     my ($sv,$ix) = @_;
 269     my $stashix = $sv->SvSTASH->ix;
 270     $sv->B::PVNV::bsave($ix);
 271     asm "xmg_stash", $stashix;
 272     $sv->domagic($ix) if $sv->MAGICAL;
 273 }
 274
 275 sub B::PVLV::bsave {
 276     my ($sv,$ix) = @_;
 277     my $targix = $sv->TARG->ix;
 278     $sv->B::PVMG::bsave($ix);
 279     asm "xlv_targ", $targix;
 280     asm "xlv_targoff", $sv->TARGOFF;
 281     asm "xlv_targlen", $sv->TARGLEN;
 282     asm "xlv_type", $sv->TYPE;
 283
 284 }
 285
 286 sub B::BM::bsave {
 287     my ($sv,$ix) = @_;
 288     $sv->B::PVMG::bsave($ix);
 289     asm "xpv_cur", $sv->CUR;
 290     asm "xbm_useful", $sv->USEFUL;
 291     asm "xbm_previous", $sv->PREVIOUS;
 292     asm "xbm_rare", $sv->RARE;
 293 }
 294
 295 sub B::IO::bsave {
 296     my ($io,$ix) = @_;
 297     my $topix = $io->TOP_GV->ix;
 298     my $fmtix = $io->FMT_GV->ix;
 299     my $bottomix = $io->BOTTOM_GV->ix;
 300     $io->B::PVMG::bsave($ix);
 301     asm "xio_lines", $io->LINES;
 302     asm "xio_page", $io->PAGE;
 303     asm "xio_page_len", $io->PAGE_LEN;
 304     asm "xio_lines_left", $io->LINES_LEFT;
 305     asm "xio_top_name", pvix $io->TOP_NAME;
 306     asm "xio_top_gv", $topix;
 307     asm "xio_fmt_name", pvix $io->FMT_NAME;
 308     asm "xio_fmt_gv", $fmtix;
 309     asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
 310     asm "xio_bottom_gv", $bottomix;
 311     asm "xio_subprocess", $io->SUBPROCESS;
 312     asm "xio_type", ord $io->IoTYPE;
 313     # asm "xio_flags", ord($io->IoFLAGS) & ~32;         # XXX XXX
 314 }
 315
 316 sub B::CV::bsave {
 317     my ($cv,$ix) = @_;
 318     my $stashix = $cv->STASH->ix;
 319     my $startix = $cv->START->opwalk;
 320     my $rootix = $cv->ROOT->ix;
 321     my $gvix = $cv->GV->ix;
 322     my $padlistix = $cv->PADLIST->ix;
 323     my $outsideix = $cv->OUTSIDE->ix;
 324     my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
 325
 326     $cv->B::PVMG::bsave($ix);
 327     asm "xcv_stash", $stashix;
 328     asm "xcv_start", $startix;
 329     asm "xcv_root", $rootix;
 330     asm "xcv_xsubany", $constix;
 331     asm "xcv_gv", $gvix;
 332     asm "xcv_file", pvix $cv->FILE if $cv->FILE;        # XXX AD
 333     asm "xcv_padlist", $padlistix;
 334     asm "xcv_outside", $outsideix;
 335     asm "xcv_flags", $cv->CvFLAGS;
 336     asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
 337     asm "xcv_depth", $cv->DEPTH;
 338 }
 339
 340 sub B::FM::bsave {
 341     my ($form,$ix) = @_;
 342
 343     $form->B::CV::bsave($ix);
 344     asm "xfm_lines", $form->LINES;
 345 }
 346
 347 sub B::AV::bsave {
 348     my ($av,$ix) = @_;
 349     return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
 350     my @array = $av->ARRAY;
 351     $_ = $_->ix for @array;
 352     my $stashix = $av->SvSTASH->ix;
 353
 354     nice "-AV-",
 355     asm "ldsv", $varix = $ix unless $ix == $varix;
 356     asm "av_extend", $av->MAX;
 357     asm "av_pushx", $_ for @array;
 358     asm "sv_refcnt", $av->REFCNT;
 359     asm "sv_flags", $av->FLAGS;
 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_fetchpv", cstring $hv->NAME . "::$k";
 386             asm "stsv", $svtab{$$v} = $varix = $tix;
 387             $v->bsave($tix++);
 388         }
 389     }
 390 }
 391
 392 ######################################################
 393
 394
 395 sub B::OP::bsave_thin {
 396     my ($op, $ix) = @_;
 397     my $next = $op->next;
 398     my $nextix = $optab{$$next};
 399     $nextix = 0, push @cloop, $op unless defined $nextix;
 400     if ($ix != $opix) {
 401         nice '-'.$op->name.'-',
 402         asm "ldop", $opix = $ix;
 403     }
 404     asm "op_type", $op->type;
 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 =~ /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     *B::BINOP::bsave = *B::OP::bsave;
 437
 438 # deal with sort / formline
 439
 440 sub B::LISTOP::bsave {
 441     my ($op, $ix) = @_;
 442     my $name = $op->name;
 443     if ($name eq 'sort' && $op->flags & (OPf_SPECIAL|OPf_STACKED)) {
 444         my $first = $op->first;
 445         my $firstix = $first->ix;
 446         my $firstsiblix = do {
 447             local *B::UNOP::bsave = *B::UNOP::bsave_fat;
 448             local *B::LISTOP::bsave = *B::UNOP::bsave_fat;
 449             $first->sibling->ix;
 450         };
 451         asm "ldop", $firstix unless $firstix == $opix;
 452         asm "op_sibling", $firstsiblix;
 453         $op->B::OP::bsave($ix);
 454         asm "op_first", $firstix;
 455     } elsif ($name eq 'formline') {
 456         $op->B::UNOP::bsave_fat($ix);
 457     } else {
 458         $op->B::OP::bsave($ix);
 459     }
 460 }
 461
 462 # fat versions
 463
 464 sub B::OP::bsave_fat {
 465     my ($op, $ix) = @_;
 466     my $siblix = $op->sibling->ix;
 467
 468     $op->B::OP::bsave_thin($ix);
 469     asm "op_sibling", $siblix;
 470     # asm "op_seq", -1;                 XXX don't allocate OPs piece by piece
 471 }
 472
 473 sub B::UNOP::bsave_fat {
 474     my ($op,$ix) = @_;
 475     my $firstix = $op->first->ix;
 476
 477     $op->B::OP::bsave($ix);
 478     asm "op_first", $firstix;
 479 }
 480
 481 sub B::BINOP::bsave_fat {
 482     my ($op,$ix) = @_;
 483     my $last = $op->last;
 484     my $lastix = $op->last->ix;
 485     if ($] < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
 486         asm "ldop", $lastix unless $lastix == $opix;
 487         asm "op_targ", $last->targ;
 488     }
 489
 490     $op->B::UNOP::bsave($ix);
 491     asm "op_last", $lastix;
 492 }
 493
 494 sub B::LOGOP::bsave {
 495     my ($op,$ix) = @_;
 496     my $otherix = $op->other->ix;
 497
 498     $op->B::UNOP::bsave($ix);
 499     asm "op_other", $otherix;
 500 }
 501
 502 sub B::PMOP::bsave {
 503     my ($op,$ix) = @_;
 504     my ($rrop, $rrarg, $rstart);
 505
 506     # my $pmnextix = $op->pmnext->ix;   # XXX
 507
 508     if ($ithreads) {
 509         if ($op->name eq 'subst') {
 510             $rrop = "op_pmreplroot";
 511             $rrarg = $op->pmreplroot->ix;
 512             $rstart = $op->pmreplstart->ix;
 513         } elsif ($op->name eq 'pushre') {
 514             $rrop = "op_pmreplrootpo";
 515             $rrarg = $op->pmreplroot;
 516         }
 517         $op->B::BINOP::bsave($ix);
 518         asm "op_pmstashpv", pvix $op->pmstashpv;
 519     } else {
 520         $rrop = "op_pmreplrootgv";
 521         $rrarg = $op->pmreplroot->ix;
 522         $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
 523         my $stashix = $op->pmstash->ix;
 524         $op->B::BINOP::bsave($ix);
 525         asm "op_pmstash", $stashix;
 526     }
 527
 528     asm $rrop, $rrarg if $rrop;
 529     asm "op_pmreplstart", $rstart if $rstart;
 530
 531     asm "op_pmflags", $op->pmflags;
 532     asm "op_pmpermflags", $op->pmpermflags;
 533     asm "op_pmdynflags", $op->pmdynflags;
 534     # asm "op_pmnext", $pmnextix;       # XXX
 535     asm "newpv", pvstring $op->precomp;
 536     asm "pregcomp";
 537 }
 538
 539 sub B::SVOP::bsave {
 540     my ($op,$ix) = @_;
 541     my $svix = $op->sv->ix;
 542
 543     $op->B::OP::bsave($ix);
 544     asm "op_sv", $svix;
 545 }
 546
 547 sub B::PADOP::bsave {
 548     my ($op,$ix) = @_;
 549
 550     $op->B::OP::bsave($ix);
 551     asm "op_padix", $op->padix;
 552 }
 553
 554 sub B::PVOP::bsave {
 555     my ($op,$ix) = @_;
 556     $op->B::OP::bsave($ix);
 557     return unless my $pv = $op->pv;
 558
 559     if ($op->name eq 'trans') {
 560         asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
 561     } else {
 562         asm "newpv", pvstring $pv;
 563         asm "op_pv";
 564     }
 565 }
 566
 567 sub B::LOOP::bsave {
 568     my ($op,$ix) = @_;
 569     my $nextix = $op->nextop->ix;
 570     my $lastix = $op->lastop->ix;
 571     my $redoix = $op->redoop->ix;
 572
 573     $op->B::BINOP::bsave($ix);
 574     asm "op_redoop", $redoix;
 575     asm "op_nextop", $nextix;
 576     asm "op_lastop", $lastix;
 577 }
 578
 579 sub B::COP::bsave {
 580     my ($cop,$ix) = @_;
 581     my $warnix = $cop->warnings->ix;
 582     my $ioix = $cop->io->ix;
 583     if ($ithreads) {
 584         $cop->B::OP::bsave($ix);
 585         asm "cop_stashpv", pvix $cop->stashpv;
 586         asm "cop_file", pvix $cop->file;
 587     } else {
 588         my $stashix = $cop->stash->ix;
 589         my $fileix = $cop->filegv->ix(1);
 590         $cop->B::OP::bsave($ix);
 591         asm "cop_stash", $stashix;
 592         asm "cop_filegv", $fileix;
 593     }
 594     asm "cop_label", pvix $cop->label if $cop->label;   # XXX AD
 595     asm "cop_seq", $cop->cop_seq;
 596     asm "cop_arybase", $cop->arybase;
 597     asm "cop_line", $cop->line;
 598     asm "cop_warnings", $warnix;
 599     asm "cop_io", $ioix;
 600 }
 601
 602 sub B::OP::opwalk {
 603     my $op = shift;
 604     my $ix = $optab{$$op};
 605     defined($ix) ? $ix : do {
 606         my $ix;
 607         my @oplist = $op->oplist;
 608         push @cloop, undef;
 609         $ix = $_->ix while $_ = pop @oplist;
 610         while ($_ = pop @cloop) {
 611             asm "ldop", $optab{$$_};
 612             asm "op_next", $optab{${$_->next}};
 613         }
 614         $ix;
 615     }
 616 }
 617
 618 #################################################
 619
 620 sub save_cq {
 621     my $av;
 622     if (($av=begin_av)->isa("B::AV")) {
 623         if ($savebegins) {
 624             for ($av->ARRAY) {
 625                 next unless $_->FILE eq $0;
 626                 asm "push_begin", $_->ix;
 627             }
 628         } else {
 629             for ($av->ARRAY) {
 630                 next unless $_->FILE eq $0;
 631                 # XXX BEGIN { exit while 1 }
 632                 for (my $op = $_->START; $$op; $op = $op->next) {
 633                     next unless $op->name =~ /require/;
 634                     asm "push_begin", $_->ix;
 635                     last;
 636                 }
 637             }
 638         }
 639     }
 640     if (($av=init_av)->isa("B::AV")) {
 641         for ($av->ARRAY) {
 642             next unless $_->FILE eq $0;
 643             asm "push_init", $_->ix;
 644         }
 645     }
 646     if (($av=end_av)->isa("B::AV")) {
 647         for ($av->ARRAY) {
 648             next unless $_->FILE eq $0;
 649             asm "push_end", $_->ix;
 650         }
 651     }
 652 }
 653
 654 sub compile {
 655     my ($head, $scan, $T_inhinc, $T_thatfile, $keep_syn);
 656     my $cwd = '';
 657     $files{$0} = 1;
 658     sub keep_syn {
 659         $keep_syn = 1;
 660         *B::OP::bsave = *B::OP::bsave_fat;
 661         *B::UNOP::bsave = *B::UNOP::bsave_fat;
 662         *B::BINOP::bsave = *B::BINOP::bsave_fat;
 663         *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
 664     }
 665     sub bwarn { print STDERR "Bytecode.pm: @_\n" }
 666
 667     for (@_) {
 668         if (/^-S/) {
 669             *newasm = *endasm = sub { };
 670             *asm = sub { print "    @_\n" };
 671             *nice = sub ($) { print "\n@_\n" };
 672         } elsif (/^-H/) {
 673             require ByteLoader;
 674             $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
 675         } elsif (/^-k/) {
 676             keep_syn;
 677         } elsif (/^-o(.*)$/) {
 678             my $ofile = $1;
 679             open STDOUT, ">$ofile" or die "open $ofile: $!";
 680             *B::COP::file = sub { $ofile } if $T_thatfile;
 681         } elsif (/^-f(.*)$/) {
 682             $files{$1} = 1;
 683         } elsif (/^-s/) {
 684             $scan = 1;
 685         } elsif (/^-b/) {
 686             $savebegins = 1;
 687     # these are here for the testsuite
 688         } elsif (/^-TD(.*)/) {
 689             $T_inhinc = 1;
 690             $cwd = $1;
 691         } elsif (/^-TF/) {
 692             $T_thatfile = 1;
 693         } else {
 694             bwarn "Ignoring '$_' option";
 695         }
 696     }
 697     if ($scan) {
 698         for(keys %files) {
 699             my $f;
 700             # KLUDGE
 701             open($f, $_) or open ($f, "$cwd/$_")
 702                 or bwarn("cannot rescan '$_'"), next;
 703             while (<$f>) {
 704                 /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
 705                 /^#/ and next;
 706                 if (/\bgoto\b/ && !$keep_syn) {
 707                     bwarn "keeping the syntax tree: \"goto\" op found";
 708                     keep_syn;
 709                 }
 710             }
 711             close $f;
 712         }
 713     }
 714     binmode STDOUT;
 715     return sub {
 716         print $head if $head;
 717         newasm sub { print @_ };
 718
 719         defstash->bwalk;
 720         asm "main_start", main_start->opwalk;
 721         asm "main_root", main_root->ix;
 722         asm "main_cv", main_cv->ix;
 723         asm "curpad", (comppadlist->ARRAY)[1]->ix;
 724
 725         asm "signal", cstring "__WARN__"                # XXX
 726             if warnhook->ix;
 727         asm "incav", inc_gv->AV->ix if $T_inhinc;
 728         save_cq;
 729         asm "incav", inc_gv->AV->ix if $T_inhinc;
 730         asm "dowarn", dowarn;
 731
 732         {
 733             no strict 'refs';
 734             nice "<DATA>";
 735             my $dh = *{defstash->NAME."::DATA"};
 736             local undef $/;
 737             if (length (my $data = <$dh>)) {
 738                 asm "data", ord 'D';
 739                 print $data;
 740             } else {
 741                 asm "ret";
 742             }
 743         }
 744
 745         endasm;
 746     }
 747 }
 748
 749 1;