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