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 @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 XSLoader::load '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 is_empty
 424
 425 This method returns TRUE if the GP field of the GV is NULL.
 426
 427 =item NAME
 428
 429 =item STASH
 430
 431 =item SV
 432
 433 =item IO
 434
 435 =item FORM
 436
 437 =item AV
 438
 439 =item HV
 440
 441 =item EGV
 442
 443 =item CV
 444
 445 =item CVGEN
 446
 447 =item LINE
 448
 449 =item FILE
 450
 451 =item FILEGV
 452
 453 =item GvREFCNT
 454
 455 =item FLAGS
 456
 457 =back
 458
 459 =head2 B::IO METHODS
 460
 461 =over 4
 462
 463 =item LINES
 464
 465 =item PAGE
 466
 467 =item PAGE_LEN
 468
 469 =item LINES_LEFT
 470
 471 =item TOP_NAME
 472
 473 =item TOP_GV
 474
 475 =item FMT_NAME
 476
 477 =item FMT_GV
 478
 479 =item BOTTOM_NAME
 480
 481 =item BOTTOM_GV
 482
 483 =item SUBPROCESS
 484
 485 =item IoTYPE
 486
 487 =item IoFLAGS
 488
 489 =back
 490
 491 =head2 B::AV METHODS
 492
 493 =over 4
 494
 495 =item FILL
 496
 497 =item MAX
 498
 499 =item OFF
 500
 501 =item ARRAY
 502
 503 =item AvFLAGS
 504
 505 =back
 506
 507 =head2 B::CV METHODS
 508
 509 =over 4
 510
 511 =item STASH
 512
 513 =item START
 514
 515 =item ROOT
 516
 517 =item GV
 518
 519 =item FILE
 520
 521 =item DEPTH
 522
 523 =item PADLIST
 524
 525 =item OUTSIDE
 526
 527 =item XSUB
 528
 529 =item XSUBANY
 530
 531 =item CvFLAGS
 532
 533 =back
 534
 535 =head2 B::HV METHODS
 536
 537 =over 4
 538
 539 =item FILL
 540
 541 =item MAX
 542
 543 =item KEYS
 544
 545 =item RITER
 546
 547 =item NAME
 548
 549 =item PMROOT
 550
 551 =item ARRAY
 552
 553 =back
 554
 555 =head2 OP-RELATED CLASSES
 556
 557 B::OP, B::UNOP, B::BINOP, B::LOGOP, B::LISTOP, B::PMOP,
 558 B::SVOP, B::PADOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
 559 These classes correspond in
 560 the obvious way to the underlying C structures of similar names. The
 561 inheritance hierarchy mimics the underlying C "inheritance". Access
 562 methods correspond to the underlying C structre field names, with the
 563 leading "class indication" prefix removed (op_).
 564
 565 =head2 B::OP METHODS
 566
 567 =over 4
 568
 569 =item next
 570
 571 =item sibling
 572
 573 =item name
 574
 575 This returns the op name as a string (e.g. "add", "rv2av").
 576
 577 =item ppaddr
 578
 579 This returns the function name as a string (e.g. "PL_ppaddr[OP_ADD]",
 580 "PL_ppaddr[OP_RV2AV]").
 581
 582 =item desc
 583
 584 This returns the op description from the global C PL_op_desc array
 585 (e.g. "addition" "array deref").
 586
 587 =item targ
 588
 589 =item type
 590
 591 =item seq
 592
 593 =item flags
 594
 595 =item private
 596
 597 =back
 598
 599 =head2 B::UNOP METHOD
 600
 601 =over 4
 602
 603 =item first
 604
 605 =back
 606
 607 =head2 B::BINOP METHOD
 608
 609 =over 4
 610
 611 =item last
 612
 613 =back
 614
 615 =head2 B::LOGOP METHOD
 616
 617 =over 4
 618
 619 =item other
 620
 621 =back
 622
 623 =head2 B::LISTOP METHOD
 624
 625 =over 4
 626
 627 =item children
 628
 629 =back
 630
 631 =head2 B::PMOP METHODS
 632
 633 =over 4
 634
 635 =item pmreplroot
 636
 637 =item pmreplstart
 638
 639 =item pmnext
 640
 641 =item pmregexp
 642
 643 =item pmflags
 644
 645 =item pmpermflags
 646
 647 =item precomp
 648
 649 =back
 650
 651 =head2 B::SVOP METHOD
 652
 653 =over 4
 654
 655 =item sv
 656
 657 =item gv
 658
 659 =back
 660
 661 =head2 B::PADOP METHOD
 662
 663 =over 4
 664
 665 =item padix
 666
 667 =back
 668
 669 =head2 B::PVOP METHOD
 670
 671 =over 4
 672
 673 =item pv
 674
 675 =back
 676
 677 =head2 B::LOOP METHODS
 678
 679 =over 4
 680
 681 =item redoop
 682
 683 =item nextop
 684
 685 =item lastop
 686
 687 =back
 688
 689 =head2 B::COP METHODS
 690
 691 =over 4
 692
 693 =item label
 694
 695 =item stash
 696
 697 =item file
 698
 699 =item cop_seq
 700
 701 =item arybase
 702
 703 =item line
 704
 705 =back
 706
 707 =head1 FUNCTIONS EXPORTED BY C<B>
 708
 709 The C<B> module exports a variety of functions: some are simple
 710 utility functions, others provide a Perl program with a way to
 711 get an initial "handle" on an internal object.
 712
 713 =over 4
 714
 715 =item main_cv
 716
 717 Return the (faked) CV corresponding to the main part of the Perl
 718 program.
 719
 720 =item init_av
 721
 722 Returns the AV object (i.e. in class B::AV) representing INIT blocks.
 723
 724 =item main_root
 725
 726 Returns the root op (i.e. an object in the appropriate B::OP-derived
 727 class) of the main part of the Perl program.
 728
 729 =item main_start
 730
 731 Returns the starting op of the main part of the Perl program.
 732
 733 =item comppadlist
 734
 735 Returns the AV object (i.e. in class B::AV) of the global comppadlist.
 736
 737 =item sv_undef
 738
 739 Returns the SV object corresponding to the C variable C<sv_undef>.
 740
 741 =item sv_yes
 742
 743 Returns the SV object corresponding to the C variable C<sv_yes>.
 744
 745 =item sv_no
 746
 747 Returns the SV object corresponding to the C variable C<sv_no>.
 748
 749 =item amagic_generation
 750
 751 Returns the SV object corresponding to the C variable C<amagic_generation>.
 752
 753 =item walkoptree(OP, METHOD)
 754
 755 Does a tree-walk of the syntax tree based at OP and calls METHOD on
 756 each op it visits. Each node is visited before its children. If
 757 C<walkoptree_debug> (q.v.) has been called to turn debugging on then
 758 the method C<walkoptree_debug> is called on each op before METHOD is
 759 called.
 760
 761 =item walkoptree_debug(DEBUG)
 762
 763 Returns the current debugging flag for C<walkoptree>. If the optional
 764 DEBUG argument is non-zero, it sets the debugging flag to that. See
 765 the description of C<walkoptree> above for what the debugging flag
 766 does.
 767
 768 =item walksymtable(SYMREF, METHOD, RECURSE)
 769
 770 Walk the symbol table starting at SYMREF and call METHOD on each
 771 symbol visited. When the walk reached package symbols "Foo::" it
 772 invokes RECURSE and only recurses into the package if that sub
 773 returns true.
 774
 775 =item svref_2object(SV)
 776
 777 Takes any Perl variable and turns it into an object in the
 778 appropriate B::OP-derived or B::SV-derived class. Apart from functions
 779 such as C<main_root>, this is the primary way to get an initial
 780 "handle" on a internal perl data structure which can then be followed
 781 with the other access methods.
 782
 783 =item ppname(OPNUM)
 784
 785 Return the PP function name (e.g. "pp_add") of op number OPNUM.
 786
 787 =item hash(STR)
 788
 789 Returns a string in the form "0x..." representing the value of the
 790 internal hash function used by perl on string STR.
 791
 792 =item cast_I32(I)
 793
 794 Casts I to the internal I32 type used by that perl.
 795
 796
 797 =item minus_c
 798
 799 Does the equivalent of the C<-c> command-line option. Obviously, this
 800 is only useful in a BEGIN block or else the flag is set too late.
 801
 802
 803 =item cstring(STR)
 804
 805 Returns a double-quote-surrounded escaped version of STR which can
 806 be used as a string in C source code.
 807
 808 =item class(OBJ)
 809
 810 Returns the class of an object without the part of the classname
 811 preceding the first "::". This is used to turn "B::UNOP" into
 812 "UNOP" for example.
 813
 814 =item threadsv_names
 815
 816 In a perl compiled for threads, this returns a list of the special
 817 per-thread threadsv variables.
 818
 819 =back
 820
 821 =head1 AUTHOR
 822
 823 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 824
 825 =cut