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