This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PVFMs don't need CvDEPTH, and PVCVs don't use SvIVX, so moving
[perl5.git] / 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     }
261     asm "xnv", sprintf "%.40g", $sv->NVX;
262 }
263
264 sub B::PVMG::domagic {
265     my ($sv,$ix) = @_;
266     nice '-MAGICAL-';
267     my @mglist = $sv->MAGIC;
268     my (@mgix, @namix);
269     for (@mglist) {
270         push @mgix, $_->OBJ->ix;
271         push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
272     }
273
274     nice '-'.class($sv).'-',
275     asm "ldsv", $varix = $ix unless $ix == $varix;
276     for (@mglist) {
277         asm "sv_magic", cstring $_->TYPE;
278         asm "mg_obj", shift @mgix;
279         my $length = $_->LENGTH;
280         if ($length == B::HEf_SVKEY) {
281             asm "mg_namex", shift @namix;
282         } elsif ($length) {
283             asm "newpv", pvstring $_->PTR;
284             asm "mg_name";
285         }
286     }
287 }
288
289 sub B::PVMG::bsave {
290     my ($sv,$ix) = @_;
291     my $stashix = $sv->SvSTASH->ix;
292     $sv->B::PVNV::bsave($ix);
293     asm "xmg_stash", $stashix;
294     $sv->domagic($ix) if $sv->MAGICAL;
295 }
296
297 sub B::PVLV::bsave {
298     my ($sv,$ix) = @_;
299     my $targix = $sv->TARG->ix;
300     $sv->B::PVMG::bsave($ix);
301     asm "xlv_targ", $targix;
302     asm "xlv_targoff", $sv->TARGOFF;
303     asm "xlv_targlen", $sv->TARGLEN;
304     asm "xlv_type", $sv->TYPE;
305
306 }
307
308 sub B::BM::bsave {
309     my ($sv,$ix) = @_;
310     $sv->B::PVMG::bsave($ix);
311     asm "xpv_cur", $sv->CUR;
312     asm "xbm_useful", $sv->USEFUL;
313     asm "xbm_previous", $sv->PREVIOUS;
314     asm "xbm_rare", $sv->RARE;
315 }
316
317 sub B::IO::bsave {
318     my ($io,$ix) = @_;
319     my $topix = $io->TOP_GV->ix;
320     my $fmtix = $io->FMT_GV->ix;
321     my $bottomix = $io->BOTTOM_GV->ix;
322     $io->B::PVMG::bsave($ix);
323     asm "xio_lines", $io->LINES;
324     asm "xio_page", $io->PAGE;
325     asm "xio_page_len", $io->PAGE_LEN;
326     asm "xio_lines_left", $io->LINES_LEFT;
327     asm "xio_top_name", pvix $io->TOP_NAME;
328     asm "xio_top_gv", $topix;
329     asm "xio_fmt_name", pvix $io->FMT_NAME;
330     asm "xio_fmt_gv", $fmtix;
331     asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
332     asm "xio_bottom_gv", $bottomix;
333     asm "xio_subprocess", $io->SUBPROCESS;
334     asm "xio_type", ord $io->IoTYPE;
335     # asm "xio_flags", ord($io->IoFLAGS) & ~32;         # XXX XXX
336 }
337
338 sub B::CV::bsave {
339     my ($cv,$ix) = @_;
340     my $stashix = $cv->STASH->ix;
341     my $gvix = $cv->GV->ix;
342     my $padlistix = $cv->PADLIST->ix;
343     my $outsideix = $cv->OUTSIDE->ix;
344     my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
345     my $startix = $cv->START->opwalk;
346     my $rootix = $cv->ROOT->ix;
347
348     $cv->B::PVMG::bsave($ix);
349     asm "xcv_stash", $stashix;
350     asm "xcv_start", $startix;
351     asm "xcv_root", $rootix;
352     asm "xcv_xsubany", $constix;
353     asm "xcv_gv", $gvix;
354     asm "xcv_file", pvix $cv->FILE if $cv->FILE;        # XXX AD
355     asm "xcv_padlist", $padlistix;
356     asm "xcv_outside", $outsideix;
357     asm "xcv_flags", $cv->CvFLAGS;
358     asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
359     asm "xcv_depth", $cv->DEPTH;
360 }
361
362 sub B::FM::bsave {
363     my ($form,$ix) = @_;
364
365     $form->B::CV::bsave($ix);
366     asm "xfm_lines", $form->LINES;
367 }
368
369 sub B::AV::bsave {
370     my ($av,$ix) = @_;
371     return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
372     my @array = $av->ARRAY;
373     $_ = $_->ix for @array;
374     my $stashix = $av->SvSTASH->ix;
375
376     nice "-AV-",
377     asm "ldsv", $varix = $ix unless $ix == $varix;
378     asm "av_extend", $av->MAX if $av->MAX >= 0;
379     asm "av_pushx", $_ for @array;
380     asm "sv_refcnt", $av->REFCNT;
381     if (VERSION < 5.009) {
382         asm "xav_flags", $av->AvFLAGS;
383     }
384     asm "xmg_stash", $stashix;
385 }
386
387 sub B::GV::desired {
388     my $gv = shift;
389     my ($cv, $form);
390     $files{$gv->FILE} && $gv->LINE
391     || ${$cv = $gv->CV} && $files{$cv->FILE}
392     || ${$form = $gv->FORM} && $files{$form->FILE}
393 }
394
395 sub B::HV::bwalk {
396     my $hv = shift;
397     return if $walked{$$hv}++;
398     my %stash = $hv->ARRAY;
399     while (my($k,$v) = each %stash) {
400         if ($v->SvTYPE == SVt_PVGV) {
401             my $hash = $v->HV;
402             if ($$hash && $hash->NAME) {
403                 $hash->bwalk;
404             } 
405             $v->ix(1) if desired $v;
406         } else {
407             nice "[prototype]";
408             asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
409             $svtab{$$v} = $varix = $tix;
410             $v->bsave($tix++);
411             asm "sv_flags", $v->FLAGS;
412         }
413     }
414 }
415
416 ######################################################
417
418
419 sub B::OP::bsave_thin {
420     my ($op, $ix) = @_;
421     my $next = $op->next;
422     my $nextix = $optab{$$next};
423     $nextix = 0, push @cloop, $op unless defined $nextix;
424     if ($ix != $opix) {
425         nice '-'.$op->name.'-',
426         asm "ldop", $opix = $ix;
427     }
428     asm "op_next", $nextix;
429     asm "op_targ", $op->targ if $op->type;              # tricky
430     asm "op_flags", $op->flags;
431     asm "op_private", $op->private;
432 }
433
434 sub B::OP::bsave;
435     *B::OP::bsave = *B::OP::bsave_thin;
436
437 sub B::UNOP::bsave {
438     my ($op, $ix) = @_;
439     my $name = $op->name;
440     my $flags = $op->flags;
441     my $first = $op->first;
442     my $firstix = 
443         $name =~ /fl[io]p/
444                         # that's just neat
445     ||  (!ITHREADS && $name eq 'regcomp')
446                         # trick for /$a/o in pp_regcomp
447     ||  $name eq 'rv2sv'
448             && $op->flags & OPf_MOD     
449             && $op->private & OPpLVAL_INTRO
450                         # change #18774 made my life hard
451     ?   $first->ix
452     :   0;
453
454     $op->B::OP::bsave($ix);
455     asm "op_first", $firstix;
456 }
457
458 sub B::BINOP::bsave {
459     my ($op, $ix) = @_;
460     if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
461         my $last = $op->last;
462         my $lastix = do {
463             local *B::OP::bsave = *B::OP::bsave_fat;
464             local *B::UNOP::bsave = *B::UNOP::bsave_fat;
465             $last->ix;
466         };
467         asm "ldop", $lastix unless $lastix == $opix;
468         asm "op_targ", $last->targ;
469         $op->B::OP::bsave($ix);
470         asm "op_last", $lastix;
471     } else {
472         $op->B::OP::bsave($ix);
473     }
474 }
475
476 # not needed if no pseudohashes
477
478 *B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
479
480 # deal with sort / formline 
481
482 sub B::LISTOP::bsave {
483     my ($op, $ix) = @_;
484     my $name = $op->name;
485     sub blocksort() { OPf_SPECIAL|OPf_STACKED }
486     if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
487         my $first = $op->first;
488         my $pushmark = $first->sibling;
489         my $rvgv = $pushmark->first;
490         my $leave = $rvgv->first;
491
492         my $leaveix = $leave->ix;
493
494         my $rvgvix = $rvgv->ix;
495         asm "ldop", $rvgvix unless $rvgvix == $opix;
496         asm "op_first", $leaveix;
497
498         my $pushmarkix = $pushmark->ix;
499         asm "ldop", $pushmarkix unless $pushmarkix == $opix;
500         asm "op_first", $rvgvix;
501
502         my $firstix = $first->ix;
503         asm "ldop", $firstix unless $firstix == $opix;
504         asm "op_sibling", $pushmarkix;
505
506         $op->B::OP::bsave($ix);
507         asm "op_first", $firstix;
508     } elsif ($name eq 'formline') {
509         $op->B::UNOP::bsave_fat($ix);
510     } else {
511         $op->B::OP::bsave($ix);
512     }
513 }
514
515 # fat versions
516
517 sub B::OP::bsave_fat {
518     my ($op, $ix) = @_;
519     my $siblix = $op->sibling->ix;
520
521     $op->B::OP::bsave_thin($ix);
522     asm "op_sibling", $siblix;
523     # asm "op_seq", -1;                 XXX don't allocate OPs piece by piece
524 }
525
526 sub B::UNOP::bsave_fat {
527     my ($op,$ix) = @_;
528     my $firstix = $op->first->ix;
529
530     $op->B::OP::bsave($ix);
531     asm "op_first", $firstix;
532 }
533
534 sub B::BINOP::bsave_fat {
535     my ($op,$ix) = @_;
536     my $last = $op->last;
537     my $lastix = $op->last->ix;
538     if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
539         asm "ldop", $lastix unless $lastix == $opix;
540         asm "op_targ", $last->targ;
541     }
542
543     $op->B::UNOP::bsave($ix);
544     asm "op_last", $lastix;
545 }
546
547 sub B::LOGOP::bsave {
548     my ($op,$ix) = @_;
549     my $otherix = $op->other->ix;
550
551     $op->B::UNOP::bsave($ix);
552     asm "op_other", $otherix;
553 }
554
555 sub B::PMOP::bsave {
556     my ($op,$ix) = @_;
557     my ($rrop, $rrarg, $rstart);
558
559     # my $pmnextix = $op->pmnext->ix;   # XXX
560
561     if (ITHREADS) {
562         if ($op->name eq 'subst') {
563             $rrop = "op_pmreplroot";
564             $rrarg = $op->pmreplroot->ix;
565             $rstart = $op->pmreplstart->ix;
566         } elsif ($op->name eq 'pushre') {
567             $rrop = "op_pmreplrootpo";
568             $rrarg = $op->pmreplroot;
569         }
570         $op->B::BINOP::bsave($ix);
571         asm "op_pmstashpv", pvix $op->pmstashpv;
572     } else {
573         $rrop = "op_pmreplrootgv";
574         $rrarg = $op->pmreplroot->ix;
575         $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
576         my $stashix = $op->pmstash->ix;
577         $op->B::BINOP::bsave($ix);
578         asm "op_pmstash", $stashix;
579     }
580
581     asm $rrop, $rrarg if $rrop;
582     asm "op_pmreplstart", $rstart if $rstart;
583
584     asm "op_pmflags", $op->pmflags;
585     asm "op_pmpermflags", $op->pmpermflags;
586     asm "op_pmdynflags", $op->pmdynflags;
587     # asm "op_pmnext", $pmnextix;       # XXX
588     asm "newpv", pvstring $op->precomp;
589     asm "pregcomp";
590 }
591
592 sub B::SVOP::bsave {
593     my ($op,$ix) = @_;
594     my $svix = $op->sv->ix;
595
596     $op->B::OP::bsave($ix);
597     asm "op_sv", $svix;
598 }
599
600 sub B::PADOP::bsave {
601     my ($op,$ix) = @_;
602
603     $op->B::OP::bsave($ix);
604     asm "op_padix", $op->padix;
605 }
606
607 sub B::PVOP::bsave {
608     my ($op,$ix) = @_;
609     $op->B::OP::bsave($ix);
610     return unless my $pv = $op->pv;
611
612     if ($op->name eq 'trans') {
613         asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
614     } else {
615         asm "newpv", pvstring $pv;
616         asm "op_pv";
617     }
618 }
619
620 sub B::LOOP::bsave {
621     my ($op,$ix) = @_;
622     my $nextix = $op->nextop->ix;
623     my $lastix = $op->lastop->ix;
624     my $redoix = $op->redoop->ix;
625
626     $op->B::BINOP::bsave($ix);
627     asm "op_redoop", $redoix;
628     asm "op_nextop", $nextix;
629     asm "op_lastop", $lastix;
630 }
631
632 sub B::COP::bsave {
633     my ($cop,$ix) = @_;
634     my $warnix = $cop->warnings->ix;
635     my $ioix = $cop->io->ix;
636     if (ITHREADS) {
637         $cop->B::OP::bsave($ix);
638         asm "cop_stashpv", pvix $cop->stashpv;
639         asm "cop_file", pvix $cop->file;
640     } else {
641         my $stashix = $cop->stash->ix;
642         my $fileix = $cop->filegv->ix(1);
643         $cop->B::OP::bsave($ix);
644         asm "cop_stash", $stashix;
645         asm "cop_filegv", $fileix;
646     }
647     asm "cop_label", pvix $cop->label if $cop->label;   # XXX AD
648     asm "cop_seq", $cop->cop_seq;
649     asm "cop_arybase", $cop->arybase;
650     asm "cop_line", $cop->line;
651     asm "cop_warnings", $warnix;
652     asm "cop_io", $ioix;
653 }
654
655 sub B::OP::opwalk {
656     my $op = shift;
657     my $ix = $optab{$$op};
658     defined($ix) ? $ix : do {
659         my $ix;
660         my @oplist = $op->oplist;
661         push @cloop, undef;
662         $ix = $_->ix while $_ = pop @oplist;
663         while ($_ = pop @cloop) {
664             asm "ldop", $optab{$$_};
665             asm "op_next", $optab{${$_->next}};
666         }
667         $ix;
668     }
669 }
670
671 #################################################
672
673 sub save_cq {
674     my $av;
675     if (($av=begin_av)->isa("B::AV")) {
676         if ($savebegins) {
677             for ($av->ARRAY) {
678                 next unless $_->FILE eq $0;
679                 asm "push_begin", $_->ix;
680             }
681         } else {
682             for ($av->ARRAY) {
683                 next unless $_->FILE eq $0;
684                 # XXX BEGIN { goto A while 1; A: }
685                 for (my $op = $_->START; $$op; $op = $op->next) {
686                     next unless $op->name eq 'require' || 
687                         # this kludge needed for tests
688                         $op->name eq 'gv' && do {
689                             my $gv = class($op) eq 'SVOP' ?
690                                 $op->gv :
691                                 (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
692                             $$gv && $gv->NAME =~ /use_ok|plan/
693                         };
694                     asm "push_begin", $_->ix;
695                     last;
696                 }
697             }
698         }
699     }
700     if (($av=init_av)->isa("B::AV")) {
701         for ($av->ARRAY) {
702             next unless $_->FILE eq $0;
703             asm "push_init", $_->ix;
704         }
705     }
706     if (($av=end_av)->isa("B::AV")) {
707         for ($av->ARRAY) {
708             next unless $_->FILE eq $0;
709             asm "push_end", $_->ix;
710         }
711     }
712 }
713
714 sub compile {
715     my ($head, $scan, $T_inhinc, $keep_syn);
716     my $cwd = '';
717     $files{$0} = 1;
718     sub keep_syn {
719         $keep_syn = 1;
720         *B::OP::bsave = *B::OP::bsave_fat;
721         *B::UNOP::bsave = *B::UNOP::bsave_fat;
722         *B::BINOP::bsave = *B::BINOP::bsave_fat;
723         *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
724     }
725     sub bwarn { print STDERR "Bytecode.pm: @_\n" }
726
727     for (@_) {
728         if (/^-S/) {
729             *newasm = *endasm = sub { };
730             *asm = sub { print "    @_\n" };
731             *nice = sub ($) { print "\n@_\n" };
732         } elsif (/^-H/) {
733             require ByteLoader;
734             $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
735         } elsif (/^-k/) {
736             keep_syn;
737         } elsif (/^-o(.*)$/) {
738             open STDOUT, ">$1" or die "open $1: $!";
739         } elsif (/^-f(.*)$/) {
740             $files{$1} = 1;
741         } elsif (/^-s(.*)$/) {
742             $scan = length($1) ? $1 : $0;
743         } elsif (/^-b/) {
744             $savebegins = 1;
745     # this is here for the testsuite
746         } elsif (/^-TI/) {
747             $T_inhinc = 1;
748         } elsif (/^-TF(.*)/) {
749             my $thatfile = $1;
750             *B::COP::file = sub { $thatfile };
751         } else {
752             bwarn "Ignoring '$_' option";
753         }
754     }
755     if ($scan) {
756         my $f;
757         if (open $f, $scan) {
758             while (<$f>) {
759                 /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
760                 /^#/ and next;
761                 if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
762                     bwarn "keeping the syntax tree: \"goto\" op found";
763                     keep_syn;
764                 }
765             }
766         } else {
767             bwarn "cannot rescan '$scan'";
768         }
769         close $f;
770     }
771     binmode STDOUT;
772     return sub {
773         print $head if $head;
774         newasm sub { print @_ };
775
776         defstash->bwalk;
777         asm "main_start", main_start->opwalk;
778         asm "main_root", main_root->ix;
779         asm "main_cv", main_cv->ix;
780         asm "curpad", (comppadlist->ARRAY)[1]->ix;
781
782         asm "signal", cstring "__WARN__"                # XXX
783             if warnhook->ix;
784         asm "incav", inc_gv->AV->ix if $T_inhinc;
785         save_cq;
786         asm "incav", inc_gv->AV->ix if $T_inhinc;
787         asm "dowarn", dowarn;
788
789         {
790             no strict 'refs';
791             nice "<DATA>";
792             my $dh = *{defstash->NAME."::DATA"};
793             unless (eof $dh) {
794                 local undef $/;
795                 asm "data", ord 'D';
796                 print <$dh>;
797             } else {
798                 asm "ret";
799             }
800         }
801
802         endasm;
803     }
804 }
805
806 1;
807
808 =head1 NAME
809
810 B::Bytecode - Perl compiler's bytecode backend
811
812 =head1 SYNOPSIS
813
814 B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
815
816 =head1 DESCRIPTION
817
818 Compiles a Perl script into a bytecode format that could be loaded
819 later by the ByteLoader module and executed as a regular Perl script.
820
821 =head1 EXAMPLE
822
823     $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
824     $ perl hi
825     hi!
826
827 =head1 OPTIONS
828
829 =over 4
830
831 =item B<-b>
832
833 Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
834 other files (ex. C<use Foo;>) are saved.
835
836 =item B<-H>
837
838 prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
839
840 =item B<-k>
841
842 keep the syntax tree - it is stripped by default.
843
844 =item B<-o>I<outfile>
845
846 put the bytecode in <outfile> instead of dumping it to STDOUT.
847
848 =item B<-s>
849
850 scan the script for C<# line ..> directives and for <goto LABEL>
851 expressions. When gotos are found keep the syntax tree.
852
853 =back
854
855 =head1 KNOWN BUGS
856
857 =over 4
858
859 =item *
860
861 C<BEGIN { goto A: while 1; A: }> won't even compile.
862
863 =item *
864
865 C<?...?> and C<reset> do not work as expected.
866
867 =item *
868
869 variables in C<(?{ ... })> constructs are not properly scoped.
870
871 =item *
872
873 scripts that use source filters will fail miserably. 
874
875 =back
876
877 =head1 NOTICE
878
879 There are also undocumented bugs and options.
880
881 THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
882
883 =head1 AUTHORS
884
885 Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
886 modified by Benjamin Stuhl <sho_pi@hotmail.com>.
887
888 Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.
889
890 =cut