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::" && $sym ne "<none>::" && &$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 =item const_sv
 535
 536 =back
 537
 538 =head2 B::HV METHODS
 539
 540 =over 4
 541
 542 =item FILL
 543
 544 =item MAX
 545
 546 =item KEYS
 547
 548 =item RITER
 549
 550 =item NAME
 551
 552 =item PMROOT
 553
 554 =item ARRAY
 555
 556 =back
 557
 558 =head2 OP-RELATED CLASSES
 559
 560 B::OP, B::UNOP, B::BINOP, B::LOGOP, B::LISTOP, B::PMOP,
 561 B::SVOP, B::PADOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
 562 These classes correspond in
 563 the obvious way to the underlying C structures of similar names. The
 564 inheritance hierarchy mimics the underlying C "inheritance". Access
 565 methods correspond to the underlying C structre field names, with the
 566 leading "class indication" prefix removed (op_).
 567
 568 =head2 B::OP METHODS
 569
 570 =over 4
 571
 572 =item next
 573
 574 =item sibling
 575
 576 =item name
 577
 578 This returns the op name as a string (e.g. "add", "rv2av").
 579
 580 =item ppaddr
 581
 582 This returns the function name as a string (e.g. "PL_ppaddr[OP_ADD]",
 583 "PL_ppaddr[OP_RV2AV]").
 584
 585 =item desc
 586
 587 This returns the op description from the global C PL_op_desc array
 588 (e.g. "addition" "array deref").
 589
 590 =item targ
 591
 592 =item type
 593
 594 =item seq
 595
 596 =item flags
 597
 598 =item private
 599
 600 =back
 601
 602 =head2 B::UNOP METHOD
 603
 604 =over 4
 605
 606 =item first
 607
 608 =back
 609
 610 =head2 B::BINOP METHOD
 611
 612 =over 4
 613
 614 =item last
 615
 616 =back
 617
 618 =head2 B::LOGOP METHOD
 619
 620 =over 4
 621
 622 =item other
 623
 624 =back
 625
 626 =head2 B::LISTOP METHOD
 627
 628 =over 4
 629
 630 =item children
 631
 632 =back
 633
 634 =head2 B::PMOP METHODS
 635
 636 =over 4
 637
 638 =item pmreplroot
 639
 640 =item pmreplstart
 641
 642 =item pmnext
 643
 644 =item pmregexp
 645
 646 =item pmflags
 647
 648 =item pmpermflags
 649
 650 =item precomp
 651
 652 =back
 653
 654 =head2 B::SVOP METHOD
 655
 656 =over 4
 657
 658 =item sv
 659
 660 =item gv
 661
 662 =back
 663
 664 =head2 B::PADOP METHOD
 665
 666 =over 4
 667
 668 =item padix
 669
 670 =back
 671
 672 =head2 B::PVOP METHOD
 673
 674 =over 4
 675
 676 =item pv
 677
 678 =back
 679
 680 =head2 B::LOOP METHODS
 681
 682 =over 4
 683
 684 =item redoop
 685
 686 =item nextop
 687
 688 =item lastop
 689
 690 =back
 691
 692 =head2 B::COP METHODS
 693
 694 =over 4
 695
 696 =item label
 697
 698 =item stash
 699
 700 =item file
 701
 702 =item cop_seq
 703
 704 =item arybase
 705
 706 =item line
 707
 708 =back
 709
 710 =head1 FUNCTIONS EXPORTED BY C<B>
 711
 712 The C<B> module exports a variety of functions: some are simple
 713 utility functions, others provide a Perl program with a way to
 714 get an initial "handle" on an internal object.
 715
 716 =over 4
 717
 718 =item main_cv
 719
 720 Return the (faked) CV corresponding to the main part of the Perl
 721 program.
 722
 723 =item init_av
 724
 725 Returns the AV object (i.e. in class B::AV) representing INIT blocks.
 726
 727 =item main_root
 728
 729 Returns the root op (i.e. an object in the appropriate B::OP-derived
 730 class) of the main part of the Perl program.
 731
 732 =item main_start
 733
 734 Returns the starting op of the main part of the Perl program.
 735
 736 =item comppadlist
 737
 738 Returns the AV object (i.e. in class B::AV) of the global comppadlist.
 739
 740 =item sv_undef
 741
 742 Returns the SV object corresponding to the C variable C<sv_undef>.
 743
 744 =item sv_yes
 745
 746 Returns the SV object corresponding to the C variable C<sv_yes>.
 747
 748 =item sv_no
 749
 750 Returns the SV object corresponding to the C variable C<sv_no>.
 751
 752 =item amagic_generation
 753
 754 Returns the SV object corresponding to the C variable C<amagic_generation>.
 755
 756 =item walkoptree(OP, METHOD)
 757
 758 Does a tree-walk of the syntax tree based at OP and calls METHOD on
 759 each op it visits. Each node is visited before its children. If
 760 C<walkoptree_debug> (q.v.) has been called to turn debugging on then
 761 the method C<walkoptree_debug> is called on each op before METHOD is
 762 called.
 763
 764 =item walkoptree_debug(DEBUG)
 765
 766 Returns the current debugging flag for C<walkoptree>. If the optional
 767 DEBUG argument is non-zero, it sets the debugging flag to that. See
 768 the description of C<walkoptree> above for what the debugging flag
 769 does.
 770
 771 =item walksymtable(SYMREF, METHOD, RECURSE)
 772
 773 Walk the symbol table starting at SYMREF and call METHOD on each
 774 symbol visited. When the walk reached package symbols "Foo::" it
 775 invokes RECURSE and only recurses into the package if that sub
 776 returns true.
 777
 778 =item svref_2object(SV)
 779
 780 Takes any Perl variable and turns it into an object in the
 781 appropriate B::OP-derived or B::SV-derived class. Apart from functions
 782 such as C<main_root>, this is the primary way to get an initial
 783 "handle" on a internal perl data structure which can then be followed
 784 with the other access methods.
 785
 786 =item ppname(OPNUM)
 787
 788 Return the PP function name (e.g. "pp_add") of op number OPNUM.
 789
 790 =item hash(STR)
 791
 792 Returns a string in the form "0x..." representing the value of the
 793 internal hash function used by perl on string STR.
 794
 795 =item cast_I32(I)
 796
 797 Casts I to the internal I32 type used by that perl.
 798
 799
 800 =item minus_c
 801
 802 Does the equivalent of the C<-c> command-line option. Obviously, this
 803 is only useful in a BEGIN block or else the flag is set too late.
 804
 805
 806 =item cstring(STR)
 807
 808 Returns a double-quote-surrounded escaped version of STR which can
 809 be used as a string in C source code.
 810
 811 =item class(OBJ)
 812
 813 Returns the class of an object without the part of the classname
 814 preceding the first "::". This is used to turn "B::UNOP" into
 815 "UNOP" for example.
 816
 817 =item threadsv_names
 818
 819 In a perl compiled for threads, this returns a list of the special
 820 per-thread threadsv variables.
 821
 822 =back
 823
 824 =head1 AUTHOR
 825
 826 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 827
 828 =cut