Re: [PATCH 5.005_57] pp_sort sorted out

	Message-ID: <19990603075749.86665.qmail@hotmail.com>

p4raw-id: //depot/perl@3584

diff --git a/ext/B/B/Bblock.pm b/ext/B/B/Bblock.pm
index 14001b3..ba6293b 100644 (file)
--- a/ext/B/B/Bblock.pm
+++ b/ext/B/B/Bblock.pm
@@ -4,7 +4,7 @@ use Exporter ();
 @EXPORT_OK = qw(find_leaders);
 
 use B qw(peekop walkoptree walkoptree_exec
-        main_root main_start svref_2object);
+        main_root main_start svref_2object OPf_SPECIAL OPf_STACKED);
 use B::Terse;
 use strict;
 
@@ -17,12 +17,19 @@ sub mark_leader {
        $bblock->{$$op} = $op;
     }
 }
+sub remove_sortblocks{
+    foreach (keys %$bblock) {
+        my $leader = $$bblock{$_};
+       delete  $$bblock{$_} if ( $leader == 0);
+    }
+}
 
 sub find_leaders {
     my ($root, $start) = @_;
     $bblock = {};
     mark_leader($start) if ( ref $start ne "B::NULL" );
     walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ;
+    remove_sortblocks();
     return $bblock;
 }
 
@@ -99,14 +106,16 @@ sub B::CONDOP::mark_if_leader {
 
 sub B::LISTOP::mark_if_leader {
     my $op = shift;
-    mark_leader($op->first);
+    my $first=$op->first;
+    $first=$first->next        while ($first->ppaddr eq "pp_null"); #remove optimed
+    mark_leader($op->first) unless (exists( $bblock->{$$first}));
     mark_leader($op->next);
+    if ($op->ppaddr eq "pp_sort" && $op->flags
+       & OPf_SPECIAL && $op->flags & OPf_STACKED){     
+         my $root=$op->first->sibling->first;
+         my $leader=$root->first;
+         $bblock->{$$leader} = 0;
 }
-
-sub B::LISTOP::mark_if_leader {
-    my $op = shift;
-    mark_leader($op->first);
-    mark_leader($op->next);
 }
 
 sub B::PMOP::mark_if_leader {

diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm
index a8f20a9..7f29543 100644 (file)
--- a/ext/B/B/C.pm
+++ b/ext/B/B/C.pm
@@ -1262,7 +1262,7 @@ sub delete_unsaved_hashINC{
        my $packname=shift;
        $packname =~ s/\:\:/\//g;
        $packname .= '.pm';
-       warn "deleting $packname" if $INC{$packname} ;# debug
+#      warn "deleting $packname" if $INC{$packname} ;# debug
        delete $INC{$packname};
 }
 sub walkpackages 

diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm
index d2aae92..059491d 100644 (file)
--- a/ext/B/B/CC.pm
+++ b/ext/B/B/CC.pm
@@ -92,7 +92,9 @@ sub init_hash { map { $_ => 1 } @_ }
 #
 %skip_lexicals = init_hash qw(pp_enter pp_enterloop);
 %skip_invalidate = init_hash qw(pp_enter pp_enterloop);
-%need_curcop = init_hash qw(pp_rv2gv  pp_bless pp_repeat pp_sort pp_caller pp_reset pp_rv2cv pp_entereval pp_require pp_dofile pp_entertry pp_enterloop pp_enteriter pp_entersub pp_enter);
+%need_curcop = init_hash qw(pp_rv2gv  pp_bless pp_repeat pp_sort
+        pp_caller pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
+        pp_entertry pp_enterloop pp_enteriter pp_entersub pp_enter);
 
 sub debug {
     if ($debug_runtime) {
@@ -585,10 +587,44 @@ sub pp_dbstate {
 #sub pp_repeat { $curcop->write_back; default_pp(@_) }
 # The following subs need $curcop->write_back if we decide to support arybase:
 # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
-#sub pp_sort { $curcop->write_back; default_pp(@_) }
 #sub pp_caller { $curcop->write_back; default_pp(@_) }
 #sub pp_reset { $curcop->write_back; default_pp(@_) }
 
+sub pp_sort {
+    my $op = shift;
+    my $ppname = $op->ppaddr;
+    if ($op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){
+       #this indicates the "sort BLOCK Array" case 
+        #ugly optree surgery required.
+       my $root=$op->first->sibling->first;
+       my $start=$root->first;
+       $op->first->save;
+       $op->first->sibling->save;
+       $root->save;
+       $start->save;
+       my $sym=objsym($start);
+       my $fakeop=cc_queue("pp_sort".$$op,$root,$start);       
+       $init->add(sprintf("($sym)->op_next=%s;",$fakeop));
+    } 
+    $curcop->write_back;
+    write_back_lexicals(); 
+    write_back_stack(); 
+    doop($op);
+    return $op->next;
+}
+
+sub pp_leavesub{
+    my $op = shift;
+    my $ppname = $op->ppaddr;
+    write_back_lexicals() unless $skip_lexicals{$ppname};
+    write_back_stack() unless $skip_stack{$ppname};
+    runtime("if (PL_curstackinfo->si_type == PERLSI_SORT) {");
+    runtime("\tPUTBACK;return 0;");
+    runtime("}");
+    doop($op);
+    return $op->next;
+}
+
 sub pp_gv {
     my $op = shift;
     my $gvsym = $op->gv->save;