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