#!/usr/bin/perl
#!/usr/bin/perl
##############################################################################
# Time-stamp: <Wed Nov 22 2000 02:59:53 Stardate: [-30]5765.62 hwloidl>
#
# Usage: gr2qp [options]
#
# Filter that transforms a GrAnSim profile (a .gr file) at stdin to  
# a quasi-parallel profile (a .qp file). It is the common front-end for most
# visualization tools (except gr2pe). It collects  running,
# runnable and blocked tasks in queues of different `colours', whose meaning
# is:
#  G ... green;   queue of all running tasks
#  A ... amber;   queue of all runnable tasks
#  R ... red;     queue of all blocked tasks
#  Y ... cyan;    queue of fetching tasks 
#  C ... crimson; queue of tasks that are being stolen
#  B ... blue;    queue of all sparks
#
# Options:
#  -i <int>  ... info level from 1 to 7; number of queues to count (see qp3ps)
#  -I <str>  ... count tasks that are in one of the given queues; encoding:
#                 'a' ... active (running)
#                 'r' ... runnable
#                 'b' ... blocked
#                 'f' ... fetching
#                 'm' ... migrating
#                 's' ... sparks
#                (e.g. -I "arb" counts sum of active, runnable, blocked tasks)
#  -C        ... do sanity checks on log file (mainly for debugging)
#  -D        ... debugging
#  -v        ... be talkative. 
#  -h        ... print help message (this header).
#
##############################################################################

require "getopts.pl";

&Getopts('hvDSCi:I:Q:');  

do process_options();

if ( $opt_v ) {
    do print_verbose_message();
}

# ---------------------------------------------------------------------------
# Init
# ---------------------------------------------------------------------------

$max = 0;
$pmax = 0;
$ptotal = 0;
$n = 0;

$active = 0;
$runnable = 0;
$blocked = 0;
$fetching = 0;
$migrating = 0;
$sparks = 0;

$found_set_cc = 0;

# NB: This version doesn't handle gum style files properly for generating
#     per-thread (ap) profiles. A hashing fct from thread-id, PE-id to a 
#     unique key is needed but not yet implemented!
$gum_warned = 0;
#     max number of threads allowed on one PE in a gum style profile
$hash_max = $opt_Q ? $opt_Q : 1000;

# The following is necessary to  check whether sort  is broken or not.  GNU
# sort provides a -s option, which guarantees that the relative ordering of
# lines with the same key  is preserved. If we  don't have a sort with this
# guarantee we have to fool it by calling ghc-fool-sort and ghc-unfool-sort
# before and after sorting a .qp file.

# print "Testing -s option on sort\n" if ( $opt_v );
`sort -s </dev/null 2>/dev/null`;
if ( $? ) { 
  print STDERR "Using ghc-fool-sort to maintain ordering of simultaneous events\n" if ( $opt_v );
  open (FOOL,"| ghc-fool-sort $improved_sort_option | sort -n +0 -1 | ghc-unfool-sort") || die "FOOL";
  $improved_sort_option = $opt_S ? "-S" : "";
} else {
  print STDERR "Using -s option of sort to maintain ordering of simultaneous events\n" if ( $opt_v );
  open (FOOL,"| sort -n +0 -1 -s") || die "Foolless sort";
}

print STDERR "%% Format of debugging info (printed after processing a line):\n" if $opt_D;
print STDERR "%% [time] Qs (act,runnable,blocked,fetch,mig,sp) max\n" if $opt_D;

$in_header = 9; 
while(<>) {
    if ( $in_header == 8 ) {
	$start_time = $1 if /^Start-Time: (.*)$/;
	$in_header = 0;
	next;
    }
    if ( $in_header == 9 ) {
        if (/^=/) {
	    $gum_style_gr = 1;
	    $in_header = 8;
	    #print STDERR "GUM STYLE GR";
	    next;
	} else {
	    $gum_style_gr = 0;
	    $in_header = 1;
	    #print STDERR "not a GUM STYLE GR";
	}
	
    }
    if (/^\++$/) {
	$in_header=0;
	next;
    }
    next if $in_header;
    next if /^$/;
    next if /^=/;
    chop;
    ($PE, $pe, $time, $act, $tid, $rest) = split;
    $tid = hex $tid;
    #print STDERR "==> |" . $tid . "| " . $_ . "\n" if $tid>$hash_max;
    $time =~ s/[\[\]:]//g;
    # next if $act eq 'REPLY';
    # chop($tid) if $act eq 'END';
    # NB: in a gum-style profile $tid is not unique; i.e. we have to hash
    #     ($PE, $tid) into a unique $tid (and there shouldn't be big gaps in
    #     the address space, because it's used as index to perl-arrays)
    $tid = &hash($pe,$tid)   if $gum_style_gr ;
    $from = $queue{$tid};
    $extra = "";
    if ($act eq 'START') {
	$from = '*';
	$to = 'G';
	$extra = " PE $pe";                # could be used for pre-PE profile
	$n++;
	if ( $n > $pmax ) { $pmax = $n; }
	$ptotal++;
    } elsif ($act eq 'START(Q)') {
	$from = '*';
	$to = 'A';
	$extra = " PE $pe";                # could be used for pre-PE profile
	$n++;
	if ( $n > $pmax ) { $pmax = $n; }
	$ptotal++;
    } elsif ($act eq 'STEALING') {
	$to = 'C';
	$extra = " PE $pe";                # could be used for pre-PE profile
    } elsif ($act eq 'STOLEN') {
	$to = 'G';
	$extra = " PE $pe";                # could be used for pre-PE profile
    } elsif ($act eq 'STOLEN(Q)') {
	$to = 'A';
	$extra = " PE $pe";                # could be used for pre-PE profile
    } elsif ($act eq 'FETCH') {
	$to = 'Y';
	$extra = " PE $pe";                # could be used for pre-PE profile
    } elsif ($act eq 'REPLY') {
	$to = 'R';
	$extra = " PE $pe";                # could be used for pre-PE profile
    } elsif ($act eq 'BLOCK') {
	$to = 'R';
	$extra = " PE $pe";                # could be used for pre-PE profile
    } elsif ($act eq 'RESUME') {
	$to = 'G';
	$extra = " PE $pe 0 0x0";
    } elsif ($act eq 'RESUME(Q)') {
	$to = 'A';
	$extra = " PE $pe 0 0x0";
    } elsif ($act eq 'END') {
	$to = '*';
	$extra = " PE $pe";                # could be used for pre-PE profile
	$n--;
	if ( $opt_C && $n < 0 ) { 
	    print STDERR "Error at time $time: neg. number of tasks: $n\n";
	}
    } elsif ($act eq 'SCHEDULE') {
	$to = 'G';
	$extra = " PE $pe";                # could be used for pre-PE profile
    } elsif ($act eq 'DESCHEDULE') {
	$to = 'A';
	$extra = " PE $pe";                # could be used for pre-PE profile
    # The following are only needed for spark profiling
    } elsif (($act eq 'SPARK') || ($act eq 'SPARKAT')) {
	$from = '*';
	$to = 'B';
    } elsif ($act eq 'USED') {
	$from = 'B';
	$to = '*';
    } elsif ($act eq 'PRUNED') {
	$from = 'B';
	$to = '*';
    } elsif ($act eq 'EXPORTED') {
	$from = 'B';
	$to = 'B';
    } elsif ($act eq 'ACQUIRED') {
	$from = 'B';
	$to = 'B';
    } elsif ($act eq 'SET_CC') {
	$from = 'X'; # dummy
	$to = 'X';   # dummy
	print STDERR "Cost center information ignored. Use gr2ccps to generate cost center profiles\n" if ! $found_set_cc;
	$found_set_cc = 1;
    } else {
	print STDERR "Error at time $time: unknown event $act\n";
    }
    $queue{$tid} = $to unless $to eq 'X';

    if ( $from eq '' ) {
	print STDERRR "Error at time $time: process $tid has no from queue\n";
    }
    if ($to ne $from) {
        print FOOL $time, "  ", 
	  $from, $to, " 0 0x", $tid, $extra, "\n";
    }

    if ($to ne $from) {
	# Compare with main loop in qp2ps
	if ($from eq '*') {
	} elsif ($from eq 'G') {
	    --$active;
	} elsif ($from eq 'A') {
	    --$runnable;
	} elsif ($from eq 'R') {
	    --$blocked;
	} elsif ($from eq 'B') {
	    --$sparks;
	} elsif ($from eq 'C') {
	    --$migrating;
	} elsif ($from eq 'Y') {
	    --$fetching;
	} else {
	    print STDERR "Illegal from char: $from at $time\n";
	}

	if ($to eq '*') {
	} elsif ($to eq 'G') {
	    ++$active;
	} elsif ($to eq 'A') {
	    ++$runnable;
	} elsif ($to eq 'R') {
	    ++$blocked;
	} elsif ($to eq 'B') {
	    ++$sparks;
	} elsif ($to eq 'C') {
	    ++$migrating;
	} elsif ($to eq 'Y') {
	    ++$fetching;
	} else {
	    print STDERR "Illegal to char: $to at $time\n";
	}

    }

    $curr = &count();
    if ( $curr > $max ) {
	$max = $curr;
    }

    &check_sanity() if $opt_C; # sanity check on queues
    &print_queues() if $opt_D; # debugging info 
 
    if ( $time > $tmax ) {
	$tmax = $time;
    }
    delete $queue{$tid} if $to eq '*';
    
}

print "Time: ", $tmax, " Max_selected_tasks: ", $max, 
      " Max_running_tasks: ", $pmax, " Total_tasks: ", $ptotal, "\n";

$curr = &count();
print STDERR "Inconsistent log-file: queues not empty at end of execution" if $opt_C && $curr!=0;

close(FOOL);

exit 0;

# ---------------------------------------------------------------------------
# hash function
# THIS DOESN'T WORK IN GENERAL; IT's A 2am HACK TO GET THE BOWING PRG WORKING

sub hash {
  local ($pe,$tid) = @_;
  local ($res);
  $res = $hash_max*$pe+$tid;
  print STDERR "Warning: This version of gr2qp cannot handle more than ${hash_max} threads per PE for GUM style profiles; use -Q <n> to increase that constant (PE=$pe,TID=$tid))\n", $gum_warned=1   if $gum_style_gr && ($tid>$hash_max) && !$gum_warned;
  return $res;
}

# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# Copied from qp3ps and slightly modified (we don't keep a list for each queue
# but just compute the max value we get out of all calls to count during the
# execution of the script).
# -----------------------------------------------------------------------------

# -----------------------------------------------------------------------------

sub queue_on {
    local ($queue) = @_;

    return index($show,$queue)+1;
}

# -----------------------------------------------------------------------------
# sum of threads in all queues
sub count {
    local ($res);

    $res = (($queue_on_a)  ? $active : 0) +
	   (($queue_on_r)  ? $runnable : 0) +
	   (($queue_on_b)  ? $blocked : 0) +
	   (($queue_on_f)  ? $fetching : 0) +
	   (($queue_on_m)  ? $migrating : 0) +
           (($queue_on_s)  ? $sparks : 0);

    return $res;
}

sub print_queues {
  print STDERR "%% [$time] Qs: ($active, $runnable, $blocked, $fetching, $migrating, $sparks) max=$max\n";
}

sub check_sanity {
  print STDERR "Inconsistent log-file: active<0 at $time\n" if $opt_C && $active<0;
  print STDERR "Inconsistent log-file: runnable<0 at $time\n" if $opt_C && $runnable<0;
  print STDERR "Inconsistent log-file: blocked<0 at $time\n" if $opt_C && $blocked<0;
  print STDERR "Inconsistent log-file: sparks<0 at $time\n" if $opt_C && $sparks<0;
  print STDERR "Inconsistent log-file: migrating<0 at $time\n" if $opt_C && $migrating<0;
  print STDERR "Inconsistent log-file: fetching<0 at $time\n" if $opt_C && $fetching<0;
}    

# -----------------------------------------------------------------------------
# DaH 'oH lo'lu'Qo'
# -----------------------------------------------------------------------------

sub set_values {
    local ($samples,
	   $active,$runnable,$blocked,$fetching,$sparks,$migrating) = @_;

    $G[$samples] = queue_on_a ? $active : 0;   
    $A[$samples] = queue_on_r ? $runnable : 0; 
    $R[$samples] = queue_on_b ? $blocked : 0;  
    $Y[$samples] = queue_on_f ? $fetching : 0; 
    $B[$samples] = queue_on_s ? $sparks : 0;   
    $C[$samples] = queue_on_m ? $migrating : 0;
}

# -----------------------------------------------------------------------------

sub process_options { 
    if ( $opt_h ) {                      
	open(ME,$0) || die "Can't open myself ($0): $!\n";
	$n = 0;
	while (<ME>) {
	    last if $_ =~ /^$/;
	    print $_;
	    $n++;
	}
	close(ME);
	exit ;
    }

    $show = "armfb";

    if ( $opt_i ) { 
	$show = "a"		if info_level == 1;
	$show = "ar"		if info_level == 2;
	$show = "arb"		if info_level == 3;
	$show = "arfb"		if info_level == 4;
	$show = "armfb"		if info_level == 5;
	$show = "armfbs"	if info_level == 6;
    }

    if ( $opt_I ) {
	$show = $opt_I;
    }

    if ( $opt_v ){ 
	$verbose = 1;
    }    

    $queue_on_a = &queue_on("a");
    $queue_on_r = &queue_on("r"); 
    $queue_on_b = &queue_on("b"); 
    $queue_on_f = &queue_on("f"); 
    $queue_on_s = &queue_on("s"); 
    $queue_on_m = &queue_on("m"); 
}

sub print_verbose_message { 

    print STDERR "Info-str: $show\n";
    print STDERR "The following queues are turned on: " .
	  ( $queue_on_a ? "active, " : "") .   
	  ( $queue_on_r ? "runnable, " : "") . 
	  ( $queue_on_b ? "blocked, " : "") .  
          ( $queue_on_f ? "fetching, " : "") . 
          ( $queue_on_m ? "migrating, " : "") .
	  ( $queue_on_s ? "sparks" : "") .
          "\n";
}
