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 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::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 class {
  69     my $obj = shift;
  70     my $name = ref $obj;
  71     $name =~ s/^.*:://;
  72     return $name;
  73 }
  74
  75 sub parents { \@parents }
  76
  77 # For debugging
  78 sub peekop {
  79     my $op = shift;
  80     return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
  81 }
  82
  83 sub walkoptree_slow {
  84     my($op, $method, $level) = @_;
  85     $op_count++; # just for statistics
  86     $level ||= 0;
  87     warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
  88     $op->$method($level);
  89     if ($$op && ($op->flags & OPf_KIDS)) {
  90         my $kid;
  91         unshift(@parents, $op);
  92         for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
  93             walkoptree_slow($kid, $method, $level + 1);
  94         }
  95         shift @parents;
  96     }
  97 }
  98
  99 sub compile_stats {
 100     return "Total number of OPs processed: $op_count\n";
 101 }
 102
 103 sub timing_info {
 104     my ($sec, $min, $hr) = localtime;
 105     my ($user, $sys) = times;
 106     sprintf("%02d:%02d:%02d user=$user sys=$sys",
 107             $hr, $min, $sec, $user, $sys);
 108 }
 109
 110 my %symtable;
 111 sub savesym {
 112     my ($obj, $value) = @_;
 113 #    warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
 114     $symtable{sprintf("sym_%x", $$obj)} = $value;
 115 }
 116
 117 sub objsym {
 118     my $obj = shift;
 119     return $symtable{sprintf("sym_%x", $$obj)};
 120 }
 121
 122 sub walkoptree_exec {
 123     my ($op, $method, $level) = @_;
 124     my ($sym, $ppname);
 125     my $prefix = "    " x $level;
 126     for (; $$op; $op = $op->next) {
 127         $sym = objsym($op);
 128         if (defined($sym)) {
 129             print $prefix, "goto $sym\n";
 130             return;
 131         }
 132         savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
 133         $op->$method($level);
 134         $ppname = $op->ppaddr;
 135         if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
 136             print $prefix, uc($1), " => {\n";
 137             walkoptree_exec($op->other, $method, $level + 1);
 138             print $prefix, "}\n";
 139         } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
 140             my $pmreplstart = $op->pmreplstart;
 141             if ($$pmreplstart) {
 142                 print $prefix, "PMREPLSTART => {\n";
 143                 walkoptree_exec($pmreplstart, $method, $level + 1);
 144                 print $prefix, "}\n";
 145             }
 146         } elsif ($ppname eq "pp_substcont") {
 147             print $prefix, "SUBSTCONT => {\n";
 148             walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
 149             print $prefix, "}\n";
 150             $op = $op->other;
 151         } elsif ($ppname eq "pp_cond_expr") {
 152             # pp_cond_expr never returns op_next
 153             print $prefix, "TRUE => {\n";
 154             walkoptree_exec($op->true, $method, $level + 1);
 155             print $prefix, "}\n";
 156             $op = $op->false;
 157             redo;
 158         } elsif ($ppname eq "pp_range") {
 159             print $prefix, "TRUE => {\n";
 160             walkoptree_exec($op->true, $method, $level + 1);
 161             print $prefix, "}\n", $prefix, "FALSE => {\n";
 162             walkoptree_exec($op->false, $method, $level + 1);
 163             print $prefix, "}\n";
 164         } elsif ($ppname eq "pp_enterloop") {
 165             print $prefix, "REDO => {\n";
 166             walkoptree_exec($op->redoop, $method, $level + 1);
 167             print $prefix, "}\n", $prefix, "NEXT => {\n";
 168             walkoptree_exec($op->nextop, $method, $level + 1);
 169             print $prefix, "}\n", $prefix, "LAST => {\n";
 170             walkoptree_exec($op->lastop,  $method, $level + 1);
 171             print $prefix, "}\n";
 172         } elsif ($ppname eq "pp_subst") {
 173             my $replstart = $op->pmreplstart;
 174             if ($$replstart) {
 175                 print $prefix, "SUBST => {\n";
 176                 walkoptree_exec($replstart, $method, $level + 1);
 177                 print $prefix, "}\n";
 178             }
 179         }
 180     }
 181 }
 182
 183 sub walksymtable {
 184     my ($symref, $method, $recurse, $prefix) = @_;
 185     my $sym;
 186     my $ref;
 187     no strict 'vars';
 188     local(*glob);
 189     $prefix = '' unless defined $prefix;
 190     while (($sym, $ref) = each %$symref) {
 191         *glob = "*main::".$prefix.$sym;
 192         if ($sym =~ /::$/) {
 193             $sym = $prefix . $sym;
 194             if ($sym ne "main::" && &$recurse($sym)) {
 195                 walksymtable(\%glob, $method, $recurse, $sym);
 196             }
 197         } else {
 198             svref_2object(\*glob)->EGV->$method();
 199         }
 200     }
 201 }
 202
 203 {
 204     package B::Section;
 205     my $output_fh;
 206     my %sections;
 207
 208     sub new {
 209         my ($class, $section, $symtable, $default) = @_;
 210         $output_fh ||= FileHandle->new_tmpfile;
 211         my $obj = bless [-1, $section, $symtable, $default], $class;
 212         $sections{$section} = $obj;
 213         return $obj;
 214     }
 215
 216     sub get {
 217         my ($class, $section) = @_;
 218         return $sections{$section};
 219     }
 220
 221     sub add {
 222         my $section = shift;
 223         while (defined($_ = shift)) {
 224             print $output_fh "$section->[1]\t$_\n";
 225             $section->[0]++;
 226         }
 227     }
 228
 229     sub index {
 230         my $section = shift;
 231         return $section->[0];
 232     }
 233
 234     sub name {
 235         my $section = shift;
 236         return $section->[1];
 237     }
 238
 239     sub symtable {
 240         my $section = shift;
 241         return $section->[2];
 242     }
 243
 244     sub default {
 245         my $section = shift;
 246         return $section->[3];
 247     }
 248
 249     sub output {
 250         my ($section, $fh, $format) = @_;
 251         my $name = $section->name;
 252         my $sym = $section->symtable || {};
 253         my $default = $section->default;
 254
 255         seek($output_fh, 0, 0);
 256         while (<$output_fh>) {
 257             chomp;
 258             s/^(.*?)\t//;
 259             if ($1 eq $name) {
 260                 s{(s\\_[0-9a-f]+)} {
 261                     exists($sym->{$1}) ? $sym->{$1} : $default;
 262                 }ge;
 263                 printf $fh $format, $_;
 264             }
 265         }
 266     }
 267 }
 268
 269 bootstrap B;
 270
 271 1;
 272
 273 __END__
 274
 275 =head1 NAME
 276
 277 B - The Perl Compiler
 278
 279 =head1 SYNOPSIS
 280
 281         use B;
 282
 283 =head1 DESCRIPTION
 284
 285 The C<B> module supplies classes which allow a Perl program to delve
 286 into its own innards. It is the module used to implement the
 287 "backends" of the Perl compiler. Usage of the compiler does not
 288 require knowledge of this module: see the F<O> module for the
 289 user-visible part. The C<B> module is of use to those who want to
 290 write new compiler backends. This documentation assumes that the
 291 reader knows a fair amount about perl's internals including such
 292 things as SVs, OPs and the internal symbol table and syntax tree
 293 of a program.
 294
 295 =head1 OVERVIEW OF CLASSES
 296
 297 The C structures used by Perl's internals to hold SV and OP
 298 information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a
 299 class hierarchy and the C<B> module gives access to them via a true
 300 object hierarchy. Structure fields which point to other objects
 301 (whether types of SV or types of OP) are represented by the C<B>
 302 module as Perl objects of the appropriate class. The bulk of the C<B>
 303 module is the methods for accessing fields of these structures. Note
 304 that all access is read-only: you cannot modify the internals by
 305 using this module.
 306
 307 =head2 SV-RELATED CLASSES
 308
 309 B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV,
 310 B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in
 311 the obvious way to the underlying C structures of similar names. The
 312 inheritance hierarchy mimics the underlying C "inheritance". Access
 313 methods correspond to the underlying C macros for field access,
 314 usually with the leading "class indication" prefix removed (Sv, Av,
 315 Hv, ...). The leading prefix is only left in cases where its removal
 316 would cause a clash in method name. For example, C<GvREFCNT> stays
 317 as-is since its abbreviation would clash with the "superclass" method
 318 C<REFCNT> (corresponding to the C function C<SvREFCNT>).
 319
 320 =head2 B::SV METHODS
 321
 322 =over 4
 323
 324 =item REFCNT
 325
 326 =item FLAGS
 327
 328 =back
 329
 330 =head2 B::IV METHODS
 331
 332 =over 4
 333
 334 =item IV
 335
 336 =item IVX
 337
 338 =item needs64bits
 339
 340 =item packiv
 341
 342 =back
 343
 344 =head2 B::NV METHODS
 345
 346 =over 4
 347
 348 =item NV
 349
 350 =item NVX
 351
 352 =back
 353
 354 =head2 B::RV METHODS
 355
 356 =over 4
 357
 358 =item RV
 359
 360 =back
 361
 362 =head2 B::PV METHODS
 363
 364 =over 4
 365
 366 =item PV
 367
 368 =back
 369
 370 =head2 B::PVMG METHODS
 371
 372 =over 4
 373
 374 =item MAGIC
 375
 376 =item SvSTASH
 377
 378 =back
 379
 380 =head2 B::MAGIC METHODS
 381
 382 =over 4
 383
 384 =item MOREMAGIC
 385
 386 =item PRIVATE
 387
 388 =item TYPE
 389
 390 =item FLAGS
 391
 392 =item OBJ
 393
 394 =item PTR
 395
 396 =back
 397
 398 =head2 B::PVLV METHODS
 399
 400 =over 4
 401
 402 =item TARGOFF
 403
 404 =item TARGLEN
 405
 406 =item TYPE
 407
 408 =item TARG
 409
 410 =back
 411
 412 =head2 B::BM METHODS
 413
 414 =over 4
 415
 416 =item USEFUL
 417
 418 =item PREVIOUS
 419
 420 =item RARE
 421
 422 =item TABLE
 423
 424 =back
 425
 426 =head2 B::GV METHODS
 427
 428 =over 4
 429
 430 =item NAME
 431
 432 =item STASH
 433
 434 =item SV
 435
 436 =item IO
 437
 438 =item FORM
 439
 440 =item AV
 441
 442 =item HV
 443
 444 =item EGV
 445
 446 =item CV
 447
 448 =item CVGEN
 449
 450 =item LINE
 451
 452 =item FILEGV
 453
 454 =item GvREFCNT
 455
 456 =item FLAGS
 457
 458 =back
 459
 460 =head2 B::IO METHODS
 461
 462 =over 4
 463
 464 =item LINES
 465
 466 =item PAGE
 467
 468 =item PAGE_LEN
 469
 470 =item LINES_LEFT
 471
 472 =item TOP_NAME
 473
 474 =item TOP_GV
 475
 476 =item FMT_NAME
 477
 478 =item FMT_GV
 479
 480 =item BOTTOM_NAME
 481
 482 =item BOTTOM_GV
 483
 484 =item SUBPROCESS
 485
 486 =item IoTYPE
 487
 488 =item IoFLAGS
 489
 490 =back
 491
 492 =head2 B::AV METHODS
 493
 494 =over 4
 495
 496 =item FILL
 497
 498 =item MAX
 499
 500 =item OFF
 501
 502 =item ARRAY
 503
 504 =item AvFLAGS
 505
 506 =back
 507
 508 =head2 B::CV METHODS
 509
 510 =over 4
 511
 512 =item STASH
 513
 514 =item START
 515
 516 =item ROOT
 517
 518 =item GV
 519
 520 =item FILEGV
 521
 522 =item DEPTH
 523
 524 =item PADLIST
 525
 526 =item OUTSIDE
 527
 528 =item XSUB
 529
 530 =item XSUBANY
 531
 532 =item CvFLAGS
 533
 534 =back
 535
 536 =head2 B::HV METHODS
 537
 538 =over 4
 539
 540 =item FILL
 541
 542 =item MAX
 543
 544 =item KEYS
 545
 546 =item RITER
 547
 548 =item NAME
 549
 550 =item PMROOT
 551
 552 =item ARRAY
 553
 554 =back
 555
 556 =head2 OP-RELATED CLASSES
 557
 558 B::OP, B::UNOP, B::BINOP, B::LOGOP, B::CONDOP, B::LISTOP, B::PMOP,
 559 B::SVOP, B::GVOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
 560 These classes correspond in
 561 the obvious way to the underlying C structures of similar names. The
 562 inheritance hierarchy mimics the underlying C "inheritance". Access
 563 methods correspond to the underlying C structre field names, with the
 564 leading "class indication" prefix removed (op_).
 565
 566 =head2 B::OP METHODS
 567
 568 =over 4
 569
 570 =item next
 571
 572 =item sibling
 573
 574 =item ppaddr
 575
 576 This returns the function name as a string (e.g. pp_add, pp_rv2av).
 577
 578 =item desc
 579
 580 This returns the op description from the global C PL_op_desc array
 581 (e.g. "addition" "array deref").
 582
 583 =item targ
 584
 585 =item type
 586
 587 =item seq
 588
 589 =item flags
 590
 591 =item private
 592
 593 =back
 594
 595 =head2 B::UNOP METHOD
 596
 597 =over 4
 598
 599 =item first
 600
 601 =back
 602
 603 =head2 B::BINOP METHOD
 604
 605 =over 4
 606
 607 =item last
 608
 609 =back
 610
 611 =head2 B::LOGOP METHOD
 612
 613 =over 4
 614
 615 =item other
 616
 617 =back
 618
 619 =head2 B::CONDOP METHODS
 620
 621 =over 4
 622
 623 =item true
 624
 625 =item false
 626
 627 =back
 628
 629 =head2 B::LISTOP METHOD
 630
 631 =over 4
 632
 633 =item children
 634
 635 =back
 636
 637 =head2 B::PMOP METHODS
 638
 639 =over 4
 640
 641 =item pmreplroot
 642
 643 =item pmreplstart
 644
 645 =item pmnext
 646
 647 =item pmregexp
 648
 649 =item pmflags
 650
 651 =item pmpermflags
 652
 653 =item precomp
 654
 655 =back
 656
 657 =head2 B::SVOP METHOD
 658
 659 =over 4
 660
 661 =item sv
 662
 663 =back
 664
 665 =head2 B::GVOP METHOD
 666
 667 =over 4
 668
 669 =item gv
 670
 671 =back
 672
 673 =head2 B::PVOP METHOD
 674
 675 =over 4
 676
 677 =item pv
 678
 679 =back
 680
 681 =head2 B::LOOP METHODS
 682
 683 =over 4
 684
 685 =item redoop
 686
 687 =item nextop
 688
 689 =item lastop
 690
 691 =back
 692
 693 =head2 B::COP METHODS
 694
 695 =over 4
 696
 697 =item label
 698
 699 =item stash
 700
 701 =item filegv
 702
 703 =item cop_seq
 704
 705 =item arybase
 706
 707 =item line
 708
 709 =back
 710
 711 =head1 FUNCTIONS EXPORTED BY C<B>
 712
 713 The C<B> module exports a variety of functions: some are simple
 714 utility functions, others provide a Perl program with a way to
 715 get an initial "handle" on an internal object.
 716
 717 =over 4
 718
 719 =item main_cv
 720
 721 Return the (faked) CV corresponding to the main part of the Perl
 722 program.
 723
 724 =item init_av
 725
 726 Returns the AV object (i.e. in class B::AV) representing INIT blocks.
 727
 728 =item main_root
 729
 730 Returns the root op (i.e. an object in the appropriate B::OP-derived
 731 class) of the main part of the Perl program.
 732
 733 =item main_start
 734
 735 Returns the starting op of the main part of the Perl program.
 736
 737 =item comppadlist
 738
 739 Returns the AV object (i.e. in class B::AV) of the global comppadlist.
 740
 741 =item sv_undef
 742
 743 Returns the SV object corresponding to the C variable C<sv_undef>.
 744
 745 =item sv_yes
 746
 747 Returns the SV object corresponding to the C variable C<sv_yes>.
 748
 749 =item sv_no
 750
 751 Returns the SV object corresponding to the C variable C<sv_no>.
 752
 753 =item amagic_generation
 754
 755 Returns the SV object corresponding to the C variable C<amagic_generation>.
 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