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