Re: [PATCH 5.005_57] pp_sort sorted out

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

p4raw-id: //depot/perl@3584

3 files changed, 55 insertions, 10 deletions

diff --git a/ext/B/B/Bblock.pm b/ext/B/B/Bblock.pm
index 14001b3c73..ba6293b1ff 100644
--- 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 a8f20a923d..7f2954354b 100644
--- 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 d2aae923f0..059491d354 100644
--- 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;