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