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