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