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