home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _d5f78c06b9de06e5ee53537308bf4a28 < prev    next >
Text File  |  2000-03-21  |  4KB  |  181 lines
  1. package B::Bblock;
  2. use Exporter ();
  3. @ISA = "Exporter";
  4. @EXPORT_OK = qw(find_leaders);
  5.  
  6. use B qw(peekop walkoptree walkoptree_exec
  7.      main_root main_start svref_2object
  8.          OPf_SPECIAL OPf_STACKED );
  9.  
  10. use B::Terse;
  11. use strict;
  12.  
  13. my $bblock;
  14. my @bblock_ends;
  15.  
  16. sub mark_leader {
  17.     my $op = shift;
  18.     if ($$op) {
  19.     $bblock->{$$op} = $op;
  20.     }
  21. }
  22.  
  23. sub remove_sortblock{
  24.     foreach (keys %$bblock){
  25.         my $leader=$$bblock{$_};    
  26.     delete $$bblock{$_} if( $leader == 0);   
  27.     }
  28. }
  29. sub find_leaders {
  30.     my ($root, $start) = @_;
  31.     $bblock = {};
  32.     mark_leader($start) if ( ref $start ne "B::NULL" );
  33.     walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ;
  34.     remove_sortblock();
  35.     return $bblock;
  36. }
  37.  
  38. # Debugging
  39. sub walk_bblocks {
  40.     my ($root, $start) = @_;
  41.     my ($op, $lastop, $leader, $bb);
  42.     $bblock = {};
  43.     mark_leader($start);
  44.     walkoptree($root, "mark_if_leader");
  45.     my @leaders = values %$bblock;
  46.     while ($leader = shift @leaders) {
  47.     $lastop = $leader;
  48.     $op = $leader->next;
  49.     while ($$op && !exists($bblock->{$$op})) {
  50.         $bblock->{$$op} = $leader;
  51.         $lastop = $op;
  52.         $op = $op->next;
  53.     }
  54.     push(@bblock_ends, [$leader, $lastop]);
  55.     }
  56.     foreach $bb (@bblock_ends) {
  57.     ($leader, $lastop) = @$bb;
  58.     printf "%s .. %s\n", peekop($leader), peekop($lastop);
  59.     for ($op = $leader; $$op != $$lastop; $op = $op->next) {
  60.         printf "    %s\n", peekop($op);
  61.     }
  62.     printf "    %s\n", peekop($lastop);
  63.     }
  64.     print "-------\n";
  65.     walkoptree_exec($start, "terse");
  66. }
  67.  
  68. sub walk_bblocks_obj {
  69.     my $cvref = shift;
  70.     my $cv = svref_2object($cvref);
  71.     walk_bblocks($cv->ROOT, $cv->START);
  72. }
  73.  
  74. sub B::OP::mark_if_leader {}
  75.  
  76. sub B::COP::mark_if_leader {
  77.     my $op = shift;
  78.     if ($op->label) {
  79.     mark_leader($op);
  80.     }
  81. }
  82.  
  83. sub B::LOOP::mark_if_leader {
  84.     my $op = shift;
  85.     mark_leader($op->next);
  86.     mark_leader($op->nextop);
  87.     mark_leader($op->redoop);
  88.     mark_leader($op->lastop->next);
  89. }
  90.  
  91. sub B::LOGOP::mark_if_leader {
  92.     my $op = shift;
  93.     my $opname = $op->name;
  94.     mark_leader($op->next);
  95.     if ($opname eq "entertry") {
  96.     mark_leader($op->other->next);
  97.     } else {
  98.     mark_leader($op->other);
  99.     }
  100. }
  101.  
  102. sub B::LISTOP::mark_if_leader {
  103.     my $op = shift;
  104.     my $first=$op->first;
  105.     $first=$first->next while ($first->name eq "null");
  106.     mark_leader($op->first) unless (exists( $bblock->{$$first}));
  107.     mark_leader($op->next);
  108.     if ($op->name eq "sort" and $op->flags & OPf_SPECIAL
  109.     and $op->flags & OPf_STACKED){
  110.         my $root=$op->first->sibling->first;
  111.         my $leader=$root->first;
  112.         $bblock->{$$leader} = 0;
  113.     }
  114. }
  115.  
  116. sub B::PMOP::mark_if_leader {
  117.     my $op = shift;
  118.     if ($op->name ne "pushre") {
  119.     my $replroot = $op->pmreplroot;
  120.     if ($$replroot) {
  121.         mark_leader($replroot);
  122.         mark_leader($op->next);
  123.         mark_leader($op->pmreplstart);
  124.     }
  125.     }
  126. }
  127.  
  128. # PMOP stuff omitted
  129.  
  130. sub compile {
  131.     my @options = @_;
  132.     B::clearsym();
  133.     if (@options) {
  134.     return sub {
  135.         my $objname;
  136.         foreach $objname (@options) {
  137.         $objname = "main::$objname" unless $objname =~ /::/;
  138.         eval "walk_bblocks_obj(\\&$objname)";
  139.         die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
  140.         }
  141.     }
  142.     } else {
  143.     return sub { walk_bblocks(main_root, main_start) };
  144.     }
  145. }
  146.  
  147. # Basic block leaders:
  148. #     Any COP (pp_nextstate) with a non-NULL label
  149. #     [The op after a pp_enter] Omit
  150. #     [The op after a pp_entersub. Don't count this one.]
  151. #     The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
  152. #     The ops pointed at by op_next and op_other of a LOGOP, except
  153. #     for pp_entertry which has op_next and op_other->op_next
  154. #     The op pointed at by op_pmreplstart of a PMOP
  155. #     The op pointed at by op_other->op_pmreplstart of pp_substcont?
  156. #     [The op after a pp_return] Omit
  157.  
  158. 1;
  159.  
  160. __END__
  161.  
  162. =head1 NAME
  163.  
  164. B::Bblock - Walk basic blocks
  165.  
  166. =head1 SYNOPSIS
  167.  
  168.     perl -MO=Bblock[,OPTIONS] foo.pl
  169.  
  170. =head1 DESCRIPTION
  171.  
  172. This module is used by the B::CC back end.  It walks "basic blocks".
  173. A basic block is a series of operations which is known to execute from
  174. start to finish, with no possiblity of branching or halting.
  175.  
  176. =head1 AUTHOR
  177.  
  178. Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
  179.  
  180. =cut
  181.