This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
75dcfb3b74d2ecae0006c11e5526c786e5955891
[perl5.git] / ext / B / B.pm
1 #      B.pm
2 #
3 #      Copyright (c) 1996, 1997, 1998 Malcolm Beattie
4 #
5 #      You may distribute under the terms of either the GNU General Public
6 #      License or the Artistic License, as specified in the README file.
7 #
8 package B;
9 require DynaLoader;
10 require Exporter;
11 @ISA = qw(Exporter DynaLoader);
12 @EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
13                 class peekop cast_I32 cstring cchar hash threadsv_names
14                 main_root main_start main_cv svref_2object
15                 walkoptree walkoptree_slow walkoptree_exec walksymtable
16                 parents comppadlist sv_undef compile_stats timing_info init_av);
17
18 use strict;
19 @B::SV::ISA = 'B::OBJECT';
20 @B::NULL::ISA = 'B::SV';
21 @B::PV::ISA = 'B::SV';
22 @B::IV::ISA = 'B::SV';
23 @B::NV::ISA = 'B::IV';
24 @B::RV::ISA = 'B::SV';
25 @B::PVIV::ISA = qw(B::PV B::IV);
26 @B::PVNV::ISA = qw(B::PV B::NV);
27 @B::PVMG::ISA = 'B::PVNV';
28 @B::PVLV::ISA = 'B::PVMG';
29 @B::BM::ISA = 'B::PVMG';
30 @B::AV::ISA = 'B::PVMG';
31 @B::GV::ISA = 'B::PVMG';
32 @B::HV::ISA = 'B::PVMG';
33 @B::CV::ISA = 'B::PVMG';
34 @B::IO::ISA = 'B::PVMG';
35 @B::FM::ISA = 'B::CV';
36
37 @B::OP::ISA = 'B::OBJECT';
38 @B::UNOP::ISA = 'B::OP';
39 @B::BINOP::ISA = 'B::UNOP';
40 @B::LOGOP::ISA = 'B::UNOP';
41 @B::CONDOP::ISA = 'B::UNOP';
42 @B::LISTOP::ISA = 'B::BINOP';
43 @B::SVOP::ISA = 'B::OP';
44 @B::GVOP::ISA = 'B::OP';
45 @B::PVOP::ISA = 'B::OP';
46 @B::CVOP::ISA = 'B::OP';
47 @B::LOOP::ISA = 'B::LISTOP';
48 @B::PMOP::ISA = 'B::LISTOP';
49 @B::COP::ISA = 'B::OP';
50
51 @B::SPECIAL::ISA = 'B::OBJECT';
52
53 {
54     # Stop "-w" from complaining about the lack of a real B::OBJECT class
55     package B::OBJECT;
56 }
57
58 my $debug;
59 my $op_count = 0;
60 my @parents = ();
61
62 sub debug {
63     my ($class, $value) = @_;
64     $debug = $value;
65     walkoptree_debug($value);
66 }
67
68 # sub OPf_KIDS;
69 # add to .xs for perl5.002
70 sub OPf_KIDS () { 4 }
71
72 sub class {
73     my $obj = shift;
74     my $name = ref $obj;
75     $name =~ s/^.*:://;
76     return $name;
77 }
78
79 sub parents { \@parents }
80
81 # For debugging
82 sub peekop {
83     my $op = shift;
84     return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
85 }
86
87 sub walkoptree_slow {
88     my($op, $method, $level) = @_;
89     $op_count++; # just for statistics
90     $level ||= 0;
91     warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
92     $op->$method($level);
93     if ($$op && ($op->flags & OPf_KIDS)) {
94         my $kid;
95         unshift(@parents, $op);
96         for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
97             walkoptree_slow($kid, $method, $level + 1);
98         }
99         shift @parents;
100     }
101 }
102
103 sub compile_stats {
104     return "Total number of OPs processed: $op_count\n";
105 }
106
107 sub timing_info {
108     my ($sec, $min, $hr) = localtime;
109     my ($user, $sys) = times;
110     sprintf("%02d:%02d:%02d user=$user sys=$sys",
111             $hr, $min, $sec, $user, $sys);
112 }
113
114 my %symtable;
115 sub savesym {
116     my ($obj, $value) = @_;
117 #    warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
118     $symtable{sprintf("sym_%x", $$obj)} = $value;
119 }
120
121 sub objsym {
122     my $obj = shift;
123     return $symtable{sprintf("sym_%x", $$obj)};
124 }
125
126 sub walkoptree_exec {
127     my ($op, $method, $level) = @_;
128     my ($sym, $ppname);
129     my $prefix = "    " x $level;
130     for (; $$op; $op = $op->next) {
131         $sym = objsym($op);
132         if (defined($sym)) {
133             print $prefix, "goto $sym\n";
134             return;
135         }
136         savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
137         $op->$method($level);
138         $ppname = $op->ppaddr;
139         if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
140             print $prefix, uc($1), " => {\n";
141             walkoptree_exec($op->other, $method, $level + 1);
142             print $prefix, "}\n";
143         } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
144             my $pmreplstart = $op->pmreplstart;
145             if ($$pmreplstart) {
146                 print $prefix, "PMREPLSTART => {\n";
147                 walkoptree_exec($pmreplstart, $method, $level + 1);
148                 print $prefix, "}\n";
149             }
150         } elsif ($ppname eq "pp_substcont") {
151             print $prefix, "SUBSTCONT => {\n";
152             walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
153             print $prefix, "}\n";
154             $op = $op->other;
155         } elsif ($ppname eq "pp_cond_expr") {
156             # pp_cond_expr never returns op_next
157             print $prefix, "TRUE => {\n";
158             walkoptree_exec($op->true, $method, $level + 1);
159             print $prefix, "}\n";
160             $op = $op->false;
161             redo;
162         } elsif ($ppname eq "pp_range") {
163             print $prefix, "TRUE => {\n";
164             walkoptree_exec($op->true, $method, $level + 1);
165             print $prefix, "}\n", $prefix, "FALSE => {\n";
166             walkoptree_exec($op->false, $method, $level + 1);
167             print $prefix, "}\n";
168         } elsif ($ppname eq "pp_enterloop") {
169             print $prefix, "REDO => {\n";
170             walkoptree_exec($op->redoop, $method, $level + 1);
171             print $prefix, "}\n", $prefix, "NEXT => {\n";
172             walkoptree_exec($op->nextop, $method, $level + 1);
173             print $prefix, "}\n", $prefix, "LAST => {\n";
174             walkoptree_exec($op->lastop,  $method, $level + 1);
175             print $prefix, "}\n";
176         } elsif ($ppname eq "pp_subst") {
177             my $replstart = $op->pmreplstart;
178             if ($$replstart) {
179                 print $prefix, "SUBST => {\n";
180                 walkoptree_exec($replstart, $method, $level + 1);
181                 print $prefix, "}\n";
182             }
183         }
184     }
185 }
186
187 sub walksymtable {
188     my ($symref, $method, $recurse, $prefix) = @_;
189     my $sym;
190     no strict 'vars';
191     local(*glob);
192     while (($sym, *glob) = each %$symref) {
193         if ($sym =~ /::$/) {
194             $sym = $prefix . $sym;
195             if ($sym ne "main::" && &$recurse($sym)) {
196                 walksymtable(\%glob, $method, $recurse, $sym);
197             }
198         } else {
199             svref_2object(\*glob)->EGV->$method();
200         }
201     }
202 }
203
204 {
205     package B::Section;
206     my $output_fh;
207     my %sections;
208     
209     sub new {
210         my ($class, $section, $symtable, $default) = @_;
211         $output_fh ||= FileHandle->new_tmpfile;
212         my $obj = bless [-1, $section, $symtable, $default], $class;
213         $sections{$section} = $obj;
214         return $obj;
215     }
216     
217     sub get {
218         my ($class, $section) = @_;
219         return $sections{$section};
220     }
221
222     sub add {
223         my $section = shift;
224         while (defined($_ = shift)) {
225             print $output_fh "$section->[1]\t$_\n";
226             $section->[0]++;
227         }
228     }
229
230     sub index {
231         my $section = shift;
232         return $section->[0];
233     }
234
235     sub name {
236         my $section = shift;
237         return $section->[1];
238     }
239
240     sub symtable {
241         my $section = shift;
242         return $section->[2];
243     }
244         
245     sub default {
246         my $section = shift;
247         return $section->[3];
248     }
249         
250     sub output {
251         my ($section, $fh, $format) = @_;
252         my $name = $section->name;
253         my $sym = $section->symtable || {};
254         my $default = $section->default;
255
256         seek($output_fh, 0, 0);
257         while (<$output_fh>) {
258             chomp;
259             s/^(.*?)\t//;
260             if ($1 eq $name) {
261                 s{(s\\_[0-9a-f]+)} {
262                     exists($sym->{$1}) ? $sym->{$1} : $default;
263                 }ge;
264                 printf $fh $format, $_;
265             }
266         }
267     }
268 }
269
270 bootstrap B;
271
272 1;
273
274 __END__
275
276 =head1 NAME
277
278 B - The Perl Compiler
279
280 =head1 SYNOPSIS
281
282         use B;
283
284 =head1 DESCRIPTION
285
286 The C<B> module supplies classes which allow a Perl program to delve
287 into its own innards. It is the module used to implement the
288 "backends" of the Perl compiler. Usage of the compiler does not
289 require knowledge of this module: see the F<O> module for the
290 user-visible part. The C<B> module is of use to those who want to
291 write new compiler backends. This documentation assumes that the
292 reader knows a fair amount about perl's internals including such
293 things as SVs, OPs and the internal symbol table and syntax tree
294 of a program.
295
296 =head1 OVERVIEW OF CLASSES
297
298 The C structures used by Perl's internals to hold SV and OP
299 information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a
300 class hierarchy and the C<B> module gives access to them via a true
301 object hierarchy. Structure fields which point to other objects
302 (whether types of SV or types of OP) are represented by the C<B>
303 module as Perl objects of the appropriate class. The bulk of the C<B>
304 module is the methods for accessing fields of these structures. Note
305 that all access is read-only: you cannot modify the internals by
306 using this module.
307
308 =head2 SV-RELATED CLASSES
309
310 B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV,
311 B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in
312 the obvious way to the underlying C structures of similar names. The
313 inheritance hierarchy mimics the underlying C "inheritance". Access
314 methods correspond to the underlying C macros for field access,
315 usually with the leading "class indication" prefix removed (Sv, Av,
316 Hv, ...). The leading prefix is only left in cases where its removal
317 would cause a clash in method name. For example, C<GvREFCNT> stays
318 as-is since its abbreviation would clash with the "superclass" method
319 C<REFCNT> (corresponding to the C function C<SvREFCNT>).
320
321 =head2 B::SV METHODS
322
323 =over 4
324
325 =item REFCNT
326
327 =item FLAGS
328
329 =back
330
331 =head2 B::IV METHODS
332
333 =over 4
334
335 =item IV
336
337 =item IVX
338
339 =item needs64bits
340
341 =item packiv
342
343 =back
344
345 =head2 B::NV METHODS
346
347 =over 4
348
349 =item NV
350
351 =item NVX
352
353 =back
354
355 =head2 B::RV METHODS
356
357 =over 4
358
359 =item RV
360
361 =back
362
363 =head2 B::PV METHODS
364
365 =over 4
366
367 =item PV
368
369 =back
370
371 =head2 B::PVMG METHODS
372
373 =over 4
374
375 =item MAGIC
376
377 =item SvSTASH
378
379 =back
380
381 =head2 B::MAGIC METHODS
382
383 =over 4
384
385 =item MOREMAGIC
386
387 =item PRIVATE
388
389 =item TYPE
390
391 =item FLAGS
392
393 =item OBJ
394
395 =item PTR
396
397 =back
398
399 =head2 B::PVLV METHODS
400
401 =over 4
402
403 =item TARGOFF
404
405 =item TARGLEN
406
407 =item TYPE
408
409 =item TARG
410
411 =back
412
413 =head2 B::BM METHODS
414
415 =over 4
416
417 =item USEFUL
418
419 =item PREVIOUS
420
421 =item RARE
422
423 =item TABLE
424
425 =back
426
427 =head2 B::GV METHODS
428
429 =over 4
430
431 =item NAME
432
433 =item STASH
434
435 =item SV
436
437 =item IO
438
439 =item FORM
440
441 =item AV
442
443 =item HV
444
445 =item EGV
446
447 =item CV
448
449 =item CVGEN
450
451 =item LINE
452
453 =item FILEGV
454
455 =item GvREFCNT
456
457 =item FLAGS
458
459 =back
460
461 =head2 B::IO METHODS
462
463 =over 4
464
465 =item LINES
466
467 =item PAGE
468
469 =item PAGE_LEN
470
471 =item LINES_LEFT
472
473 =item TOP_NAME
474
475 =item TOP_GV
476
477 =item FMT_NAME
478
479 =item FMT_GV
480
481 =item BOTTOM_NAME
482
483 =item BOTTOM_GV
484
485 =item SUBPROCESS
486
487 =item IoTYPE
488
489 =item IoFLAGS
490
491 =back
492
493 =head2 B::AV METHODS
494
495 =over 4
496
497 =item FILL
498
499 =item MAX
500
501 =item OFF
502
503 =item ARRAY
504
505 =item AvFLAGS
506
507 =back
508
509 =head2 B::CV METHODS
510
511 =over 4
512
513 =item STASH
514
515 =item START
516
517 =item ROOT
518
519 =item GV
520
521 =item FILEGV
522
523 =item DEPTH
524
525 =item PADLIST
526
527 =item OUTSIDE
528
529 =item XSUB
530
531 =item XSUBANY
532
533 =item CvFLAGS
534
535 =back
536
537 =head2 B::HV METHODS
538
539 =over 4
540
541 =item FILL
542
543 =item MAX
544
545 =item KEYS
546
547 =item RITER
548
549 =item NAME
550
551 =item PMROOT
552
553 =item ARRAY
554
555 =back
556
557 =head2 OP-RELATED CLASSES
558
559 B::OP, B::UNOP, B::BINOP, B::LOGOP, B::CONDOP, B::LISTOP, B::PMOP,
560 B::SVOP, B::GVOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
561 These classes correspond in
562 the obvious way to the underlying C structures of similar names. The
563 inheritance hierarchy mimics the underlying C "inheritance". Access
564 methods correspond to the underlying C structre field names, with the
565 leading "class indication" prefix removed (op_).
566
567 =head2 B::OP METHODS
568
569 =over 4
570
571 =item next
572
573 =item sibling
574
575 =item ppaddr
576
577 This returns the function name as a string (e.g. pp_add, pp_rv2av).
578
579 =item desc
580
581 This returns the op description from the global C PL_op_desc array
582 (e.g. "addition" "array deref").
583
584 =item targ
585
586 =item type
587
588 =item seq
589
590 =item flags
591
592 =item private
593
594 =back
595
596 =head2 B::UNOP METHOD
597
598 =over 4
599
600 =item first
601
602 =back
603
604 =head2 B::BINOP METHOD
605
606 =over 4
607
608 =item last
609
610 =back
611
612 =head2 B::LOGOP METHOD
613
614 =over 4
615
616 =item other
617
618 =back
619
620 =head2 B::CONDOP METHODS
621
622 =over 4
623
624 =item true
625
626 =item false
627
628 =back
629
630 =head2 B::LISTOP METHOD
631
632 =over 4
633
634 =item children
635
636 =back
637
638 =head2 B::PMOP METHODS
639
640 =over 4
641
642 =item pmreplroot
643
644 =item pmreplstart
645
646 =item pmnext
647
648 =item pmregexp
649
650 =item pmflags
651
652 =item pmpermflags
653
654 =item precomp
655
656 =back
657
658 =head2 B::SVOP METHOD
659
660 =over 4
661
662 =item sv
663
664 =back
665
666 =head2 B::GVOP METHOD
667
668 =over 4
669
670 =item gv
671
672 =back
673
674 =head2 B::PVOP METHOD
675
676 =over 4
677
678 =item pv
679
680 =back
681
682 =head2 B::LOOP METHODS
683
684 =over 4
685
686 =item redoop
687
688 =item nextop
689
690 =item lastop
691
692 =back
693
694 =head2 B::COP METHODS
695
696 =over 4
697
698 =item label
699
700 =item stash
701
702 =item filegv
703
704 =item cop_seq
705
706 =item arybase
707
708 =item line
709
710 =back
711
712 =head1 FUNCTIONS EXPORTED BY C<B>
713
714 The C<B> module exports a variety of functions: some are simple
715 utility functions, others provide a Perl program with a way to
716 get an initial "handle" on an internal object.
717
718 =over 4
719
720 =item main_cv
721
722 Return the (faked) CV corresponding to the main part of the Perl
723 program.
724
725 =item init_av
726
727 Returns the AV object (i.e. in class B::AV) representing INIT blocks.
728
729 =item main_root
730
731 Returns the root op (i.e. an object in the appropriate B::OP-derived
732 class) of the main part of the Perl program.
733
734 =item main_start
735
736 Returns the starting op of the main part of the Perl program.
737
738 =item comppadlist
739
740 Returns the AV object (i.e. in class B::AV) of the global comppadlist.
741
742 =item sv_undef
743
744 Returns the SV object corresponding to the C variable C<sv_undef>.
745
746 =item sv_yes
747
748 Returns the SV object corresponding to the C variable C<sv_yes>.
749
750 =item sv_no
751
752 Returns the SV object corresponding to the C variable C<sv_no>.
753
754 =item walkoptree(OP, METHOD)
755
756 Does a tree-walk of the syntax tree based at OP and calls METHOD on
757 each op it visits. Each node is visited before its children. If
758 C<walkoptree_debug> (q.v.) has been called to turn debugging on then
759 the method C<walkoptree_debug> is called on each op before METHOD is
760 called.
761
762 =item walkoptree_debug(DEBUG)
763
764 Returns the current debugging flag for C<walkoptree>. If the optional
765 DEBUG argument is non-zero, it sets the debugging flag to that. See
766 the description of C<walkoptree> above for what the debugging flag
767 does.
768
769 =item walksymtable(SYMREF, METHOD, RECURSE)
770
771 Walk the symbol table starting at SYMREF and call METHOD on each
772 symbol visited. When the walk reached package symbols "Foo::" it
773 invokes RECURSE and only recurses into the package if that sub
774 returns true.
775
776 =item svref_2object(SV)
777
778 Takes any Perl variable and turns it into an object in the
779 appropriate B::OP-derived or B::SV-derived class. Apart from functions
780 such as C<main_root>, this is the primary way to get an initial
781 "handle" on a internal perl data structure which can then be followed
782 with the other access methods.
783
784 =item ppname(OPNUM)
785
786 Return the PP function name (e.g. "pp_add") of op number OPNUM.
787
788 =item hash(STR)
789
790 Returns a string in the form "0x..." representing the value of the
791 internal hash function used by perl on string STR.
792
793 =item cast_I32(I)
794
795 Casts I to the internal I32 type used by that perl.
796
797
798 =item minus_c
799
800 Does the equivalent of the C<-c> command-line option. Obviously, this
801 is only useful in a BEGIN block or else the flag is set too late.
802
803
804 =item cstring(STR)
805
806 Returns a double-quote-surrounded escaped version of STR which can
807 be used as a string in C source code.
808
809 =item class(OBJ)
810
811 Returns the class of an object without the part of the classname
812 preceding the first "::". This is used to turn "B::UNOP" into
813 "UNOP" for example.
814
815 =item threadsv_names
816
817 In a perl compiled for threads, this returns a list of the special
818 per-thread threadsv variables.
819
820 =item byteload_fh(FILEHANDLE)
821
822 Load the contents of FILEHANDLE as bytecode. See documentation for
823 the B<Bytecode> module in F<B::Backend> for how to generate bytecode.
824
825 =back
826
827 =head1 AUTHOR
828
829 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
830
831 =cut