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