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