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 require DynaLoader;
  10 require Exporter;
  11 @ISA = qw(Exporter DynaLoader);
  12 @EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
  13                 class peekop cast_I32 cstring cchar hash threadsv_names
  14                 main_root main_start main_cv svref_2object opnumber
  15                 walkoptree walkoptree_slow walkoptree_exec walksymtable
  16                 parents comppadlist sv_undef compile_stats timing_info init_av);
  17
  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::CONDOP::ISA = 'B::UNOP';
  42 @B::LISTOP::ISA = 'B::BINOP';
  43 @B::SVOP::ISA = 'B::OP';
  44 @B::GVOP::ISA = 'B::OP';
  45 @B::PVOP::ISA = 'B::OP';
  46 @B::CVOP::ISA = 'B::OP';
  47 @B::LOOP::ISA = 'B::LISTOP';
  48 @B::PMOP::ISA = 'B::LISTOP';
  49 @B::COP::ISA = 'B::OP';
  50
  51 @B::SPECIAL::ISA = 'B::OBJECT';
  52
  53 {
  54     # Stop "-w" from complaining about the lack of a real B::OBJECT class
  55     package B::OBJECT;
  56 }
  57
  58 my $debug;
  59 my $op_count = 0;
  60 my @parents = ();
  61
  62 sub debug {
  63     my ($class, $value) = @_;
  64     $debug = $value;
  65     walkoptree_debug($value);
  66 }
  67
  68 # sub OPf_KIDS;
  69 # add to .xs for perl5.002
  70 sub OPf_KIDS () { 4 }
  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->ppaddr);
  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 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->ppaddr;
 139         if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
 140             print $prefix, uc($1), " => {\n";
 141             walkoptree_exec($op->other, $method, $level + 1);
 142             print $prefix, "}\n";
 143         } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
 144             my $pmreplstart = $op->pmreplstart;
 145             if ($$pmreplstart) {
 146                 print $prefix, "PMREPLSTART => {\n";
 147                 walkoptree_exec($pmreplstart, $method, $level + 1);
 148                 print $prefix, "}\n";
 149             }
 150         } elsif ($ppname eq "pp_substcont") {
 151             print $prefix, "SUBSTCONT => {\n";
 152             walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
 153             print $prefix, "}\n";
 154             $op = $op->other;
 155         } elsif ($ppname eq "pp_cond_expr") {
 156             # pp_cond_expr never returns op_next
 157             print $prefix, "TRUE => {\n";
 158             walkoptree_exec($op->true, $method, $level + 1);
 159             print $prefix, "}\n";
 160             $op = $op->false;
 161             redo;
 162         } elsif ($ppname eq "pp_range") {
 163             print $prefix, "TRUE => {\n";
 164             walkoptree_exec($op->true, $method, $level + 1);
 165             print $prefix, "}\n", $prefix, "FALSE => {\n";
 166             walkoptree_exec($op->false, $method, $level + 1);
 167             print $prefix, "}\n";
 168         } elsif ($ppname eq "pp_enterloop") {
 169             print $prefix, "REDO => {\n";
 170             walkoptree_exec($op->redoop, $method, $level + 1);
 171             print $prefix, "}\n", $prefix, "NEXT => {\n";
 172             walkoptree_exec($op->nextop, $method, $level + 1);
 173             print $prefix, "}\n", $prefix, "LAST => {\n";
 174             walkoptree_exec($op->lastop,  $method, $level + 1);
 175             print $prefix, "}\n";
 176         } elsif ($ppname eq "pp_subst") {
 177             my $replstart = $op->pmreplstart;
 178             if ($$replstart) {
 179                 print $prefix, "SUBST => {\n";
 180                 walkoptree_exec($replstart, $method, $level + 1);
 181                 print $prefix, "}\n";
 182             }
 183         }
 184     }
 185 }
 186
 187 sub walksymtable {
 188     my ($symref, $method, $recurse, $prefix) = @_;
 189     my $sym;
 190     my $ref;
 191     no strict 'vars';
 192     local(*glob);
 193     $prefix = '' unless defined $prefix;
 194     while (($sym, $ref) = each %$symref) {
 195         *glob = $ref;
 196         if ($sym =~ /::$/) {
 197             $sym = $prefix . $sym;
 198             if ($sym ne "main::" && &$recurse($sym)) {
 199                 walksymtable(\%glob, $method, $recurse, $sym);
 200             }
 201         } else {
 202             svref_2object(\*glob)->EGV->$method();
 203         }
 204     }
 205 }
 206
 207 {
 208     package B::Section;
 209     my $output_fh;
 210     my %sections;
 211
 212     sub new {
 213         my ($class, $section, $symtable, $default) = @_;
 214         $output_fh ||= FileHandle->new_tmpfile;
 215         my $obj = bless [-1, $section, $symtable, $default], $class;
 216         $sections{$section} = $obj;
 217         return $obj;
 218     }
 219
 220     sub get {
 221         my ($class, $section) = @_;
 222         return $sections{$section};
 223     }
 224
 225     sub add {
 226         my $section = shift;
 227         while (defined($_ = shift)) {
 228             print $output_fh "$section->[1]\t$_\n";
 229             $section->[0]++;
 230         }
 231     }
 232
 233     sub index {
 234         my $section = shift;
 235         return $section->[0];
 236     }
 237
 238     sub name {
 239         my $section = shift;
 240         return $section->[1];
 241     }
 242
 243     sub symtable {
 244         my $section = shift;
 245         return $section->[2];
 246     }
 247
 248     sub default {
 249         my $section = shift;
 250         return $section->[3];
 251     }
 252
 253     sub output {
 254         my ($section, $fh, $format) = @_;
 255         my $name = $section->name;
 256         my $sym = $section->symtable || {};
 257         my $default = $section->default;
 258
 259         seek($output_fh, 0, 0);
 260         while (<$output_fh>) {
 261             chomp;
 262             s/^(.*?)\t//;
 263             if ($1 eq $name) {
 264                 s{(s\\_[0-9a-f]+)} {
 265                     exists($sym->{$1}) ? $sym->{$1} : $default;
 266                 }ge;
 267                 printf $fh $format, $_;
 268             }
 269         }
 270     }
 271 }
 272
 273 bootstrap B;
 274
 275 1;
 276
 277 __END__
 278
 279 =head1 NAME
 280
 281 B - The Perl Compiler
 282
 283 =head1 SYNOPSIS
 284
 285         use B;
 286
 287 =head1 DESCRIPTION
 288
 289 The C<B> module supplies classes which allow a Perl program to delve
 290 into its own innards. It is the module used to implement the
 291 "backends" of the Perl compiler. Usage of the compiler does not
 292 require knowledge of this module: see the F<O> module for the
 293 user-visible part. The C<B> module is of use to those who want to
 294 write new compiler backends. This documentation assumes that the
 295 reader knows a fair amount about perl's internals including such
 296 things as SVs, OPs and the internal symbol table and syntax tree
 297 of a program.
 298
 299 =head1 OVERVIEW OF CLASSES
 300
 301 The C structures used by Perl's internals to hold SV and OP
 302 information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a
 303 class hierarchy and the C<B> module gives access to them via a true
 304 object hierarchy. Structure fields which point to other objects
 305 (whether types of SV or types of OP) are represented by the C<B>
 306 module as Perl objects of the appropriate class. The bulk of the C<B>
 307 module is the methods for accessing fields of these structures. Note
 308 that all access is read-only: you cannot modify the internals by
 309 using this module.
 310
 311 =head2 SV-RELATED CLASSES
 312
 313 B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV,
 314 B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in
 315 the obvious way to the underlying C structures of similar names. The
 316 inheritance hierarchy mimics the underlying C "inheritance". Access
 317 methods correspond to the underlying C macros for field access,
 318 usually with the leading "class indication" prefix removed (Sv, Av,
 319 Hv, ...). The leading prefix is only left in cases where its removal
 320 would cause a clash in method name. For example, C<GvREFCNT> stays
 321 as-is since its abbreviation would clash with the "superclass" method
 322 C<REFCNT> (corresponding to the C function C<SvREFCNT>).
 323
 324 =head2 B::SV METHODS
 325
 326 =over 4
 327
 328 =item REFCNT
 329
 330 =item FLAGS
 331
 332 =back
 333
 334 =head2 B::IV METHODS
 335
 336 =over 4
 337
 338 =item IV
 339
 340 =item IVX
 341
 342 =item needs64bits
 343
 344 =item packiv
 345
 346 =back
 347
 348 =head2 B::NV METHODS
 349
 350 =over 4
 351
 352 =item NV
 353
 354 =item NVX
 355
 356 =back
 357
 358 =head2 B::RV METHODS
 359
 360 =over 4
 361
 362 =item RV
 363
 364 =back
 365
 366 =head2 B::PV METHODS
 367
 368 =over 4
 369
 370 =item PV
 371
 372 =back
 373
 374 =head2 B::PVMG METHODS
 375
 376 =over 4
 377
 378 =item MAGIC
 379
 380 =item SvSTASH
 381
 382 =back
 383
 384 =head2 B::MAGIC METHODS
 385
 386 =over 4
 387
 388 =item MOREMAGIC
 389
 390 =item PRIVATE
 391
 392 =item TYPE
 393
 394 =item FLAGS
 395
 396 =item OBJ
 397
 398 =item PTR
 399
 400 =back
 401
 402 =head2 B::PVLV METHODS
 403
 404 =over 4
 405
 406 =item TARGOFF
 407
 408 =item TARGLEN
 409
 410 =item TYPE
 411
 412 =item TARG
 413
 414 =back
 415
 416 =head2 B::BM METHODS
 417
 418 =over 4
 419
 420 =item USEFUL
 421
 422 =item PREVIOUS
 423
 424 =item RARE
 425
 426 =item TABLE
 427
 428 =back
 429
 430 =head2 B::GV METHODS
 431
 432 =over 4
 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 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 FILEGV
 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 =back
 539
 540 =head2 B::HV METHODS
 541
 542 =over 4
 543
 544 =item FILL
 545
 546 =item MAX
 547
 548 =item KEYS
 549
 550 =item RITER
 551
 552 =item NAME
 553
 554 =item PMROOT
 555
 556 =item ARRAY
 557
 558 =back
 559
 560 =head2 OP-RELATED CLASSES
 561
 562 B::OP, B::UNOP, B::BINOP, B::LOGOP, B::CONDOP, B::LISTOP, B::PMOP,
 563 B::SVOP, B::GVOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
 564 These classes correspond in
 565 the obvious way to the underlying C structures of similar names. The
 566 inheritance hierarchy mimics the underlying C "inheritance". Access
 567 methods correspond to the underlying C structre field names, with the
 568 leading "class indication" prefix removed (op_).
 569
 570 =head2 B::OP METHODS
 571
 572 =over 4
 573
 574 =item next
 575
 576 =item sibling
 577
 578 =item ppaddr
 579
 580 This returns the function name as a string (e.g. pp_add, pp_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::CONDOP METHODS
 624
 625 =over 4
 626
 627 =item true
 628
 629 =item false
 630
 631 =back
 632
 633 =head2 B::LISTOP METHOD
 634
 635 =over 4
 636
 637 =item children
 638
 639 =back
 640
 641 =head2 B::PMOP METHODS
 642
 643 =over 4
 644
 645 =item pmreplroot
 646
 647 =item pmreplstart
 648
 649 =item pmnext
 650
 651 =item pmregexp
 652
 653 =item pmflags
 654
 655 =item pmpermflags
 656
 657 =item precomp
 658
 659 =back
 660
 661 =head2 B::SVOP METHOD
 662
 663 =over 4
 664
 665 =item sv
 666
 667 =back
 668
 669 =head2 B::GVOP METHOD
 670
 671 =over 4
 672
 673 =item gv
 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 filegv
 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 walkoptree(OP, METHOD)
 758
 759 Does a tree-walk of the syntax tree based at OP and calls METHOD on
 760 each op it visits. Each node is visited before its children. If
 761 C<walkoptree_debug> (q.v.) has been called to turn debugging on then
 762 the method C<walkoptree_debug> is called on each op before METHOD is
 763 called.
 764
 765 =item walkoptree_debug(DEBUG)
 766
 767 Returns the current debugging flag for C<walkoptree>. If the optional
 768 DEBUG argument is non-zero, it sets the debugging flag to that. See
 769 the description of C<walkoptree> above for what the debugging flag
 770 does.
 771
 772 =item walksymtable(SYMREF, METHOD, RECURSE)
 773
 774 Walk the symbol table starting at SYMREF and call METHOD on each
 775 symbol visited. When the walk reached package symbols "Foo::" it
 776 invokes RECURSE and only recurses into the package if that sub
 777 returns true.
 778
 779 =item svref_2object(SV)
 780
 781 Takes any Perl variable and turns it into an object in the
 782 appropriate B::OP-derived or B::SV-derived class. Apart from functions
 783 such as C<main_root>, this is the primary way to get an initial
 784 "handle" on a internal perl data structure which can then be followed
 785 with the other access methods.
 786
 787 =item ppname(OPNUM)
 788
 789 Return the PP function name (e.g. "pp_add") of op number OPNUM.
 790
 791 =item hash(STR)
 792
 793 Returns a string in the form "0x..." representing the value of the
 794 internal hash function used by perl on string STR.
 795
 796 =item cast_I32(I)
 797
 798 Casts I to the internal I32 type used by that perl.
 799
 800
 801 =item minus_c
 802
 803 Does the equivalent of the C<-c> command-line option. Obviously, this
 804 is only useful in a BEGIN block or else the flag is set too late.
 805
 806
 807 =item cstring(STR)
 808
 809 Returns a double-quote-surrounded escaped version of STR which can
 810 be used as a string in C source code.
 811
 812 =item class(OBJ)
 813
 814 Returns the class of an object without the part of the classname
 815 preceding the first "::". This is used to turn "B::UNOP" into
 816 "UNOP" for example.
 817
 818 =item threadsv_names
 819
 820 In a perl compiled for threads, this returns a list of the special
 821 per-thread threadsv variables.
 822
 823 =item byteload_fh(FILEHANDLE)
 824
 825 Load the contents of FILEHANDLE as bytecode. See documentation for
 826 the B<Bytecode> module in F<B::Backend> for how to generate bytecode.
 827
 828 =back
 829
 830 =head1 AUTHOR
 831
 832 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 833
 834 =cut