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