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