#! /usr/local/bin/perl
#
# $COPYRIGHT$
#
# Customizable LAM MPI library profiling wrapper generator.
#
# Make sure that the path in the first line refers to the Perl binary
# on your system.
#

$preamble = "preamble_trace_flush";
$postamble = "postamble_trace_flush";

%cats =  ('p2pt', 'Point-to-point',
 	  'coll', 'Collective',
 	  'comm', 'Communicators',
 	  'grps', 'Groups', 
 	  'type', 'Datatypes',
 	  'attr', 'Attributes',
 	  'topo', 'Topologies',
 	  'misc', 'Miscellaneous',
 	  'errh', 'Error handlers',
 	  'exts', 'LAM extensions',
 	  'dyna', 'Dynamic',
 	  'info', 'Info',
 	  'name', 'Name publishing',
 	  'onesided', 'One Sided'
 	);	

@p2pt = ('bsend.c', 'bsendinit.c', 'bufattach.c', 'bufdetach.c', 'cancel.c',
 	 'ibsend.c', 'iprobe.c', 'irecv.c', 'irsend.c', 'isend.c',
 	 'issend.c', 'probe.c', 'recv.c', 'recvinit.c', 'reqfree.c',
 	 'rsend.c', 'rsendinit.c', 'send.c', 'sendinit.c', 'sendrecv.c',
 	 'sendrecvrep.c', 'ssend.c', 'ssendinit.c', 'start.c', 'startall.c',
 	 'test.c', 'testcancel.c', 'testall.c', 'testany.c', 'testsome.c',
 	 'wait.c', 'waitall.c', 'waitany.c', 'waitsome.c');

@coll = ('allgather.c', 'allgatherv.c', 'allreduce.c', 'alltoall.c',
 	 'alltoallv.c', 'barrier.c', 'bcast.c', 'gather.c', 'gatherv.c',
 	 'opcreate.c', 'opfree.c', 'reduce.c', 'reducescatter.c', 'scan.c',
 	 'scatter.c', 'scatterv.c');

@comm = ('ccmp.c', 'ccreate.c', 'cdup.c', 'cfree.c', 'cgroup.c', 'crank.c',
	 'crgroup.c', 'crsize.c', 'csize.c', 'csplit.c',
	 'ctestinter.c', 'iccreate.c', 'icmerge.c');

@grps = ('gcmp.c', 'gdiff.c', 'gexcl.c', 'gfree.c', 'gincl.c', 'ginter.c',
	 'grexcl.c', 'grincl.c', 'grank.c', 'gsize.c', 'gtranks.c',
	 'gunion.c');

@type = ('pack.c', 'packsize.c', 'tcommit.c', 'tcontig.c', 'textent.c',
	 'tfree.c', 'thindex.c', 'thvector.c', 'tindex.c', 'tlb.c', 'tsize.c',
	 'tstruct.c', 'tub.c', 'tvector.c', 'unpack.c', 'tcreatehindex.c',
	 'tcreatehvector.c', 'tcreatekey.c', 'tcreatestruct.c', 'tdarray.c',
	 'tdelattr.c', 'tdup.c', 'tfreekey.c', 'tgetattr.c', 'tgetconts.c',
	 'tgetenvl.c', 'tgetextent.c', 'tgettrue.c', 'tresize.c',
	 'tsetattr.c', 'tsubarray.c');

@attr = ('attrdel.c', 'attrget.c', 'attrput.c', 'keycreate.c', 'keyfree.c');

@topo = ('cartcoords.c', 'cartcreate.c', 'cartdimget.c', 'cartget.c',
	 'cartmap.c', 'cartrank.c', 'cartshift.c', 'cartsub.c',
	 'dimscreate.c', 'graphcreate.c', 'graphdimsget.c',
	 'graphget.c', 'graphmap.c', 'graphnbr.c', 'graphnbrcount.c',
	 'topotest.c');

@misc = ('abort.c', 'address.c', 'getcount.c', 'getelem.c', 'getprocname.c',
	 'getversion.c', 'wtick.c', 'wtime.c');

@errh = ('errclass.c', 'errcreate.c', 'errfree.c', 'errget.c', 'errset.c',
	 'errstring.c');

@exts = ('mpil_spawn.c');

@dyna = ('accept.c', 'cdisconnect.c', 'connect.c', 'portopen.c',
	 'portclose.c', 'spawn.c', 'spawnmult.c', 'join.c');

@info = ('infocreate.c', 'infodel.c', 'infodup.c', 'infofree.c', 'infoget.c',
	 'infogetnkeys.c', 'infogetnth.c', 'infogetvlen.c', 'infoset.c');

@name = ('namepub.c', 'nameunpub.c', 'namelook.c');

@onesided = ('wcomplete.c', 'wcreate.c', 'wcreateerr.c', 'wcreatekey.c',
	     'wdelattr.c', 'wfence.c', 'wfree.c', 'wfreekey.c', 'wgetattr.c',
	     'wgeterr.c', 'wgroup.c', 'wpost.c', 'wsetattr.c', 'wseterr.c',
	     'wstart.c', 'wwait.c');

&init;
while (($cat,$banner) = each %cats) {
	print "/*\n * $banner.\n */\n\n";
	foreach $f (@$cat) { &wrap($f); }
}   

exit 0;

########################################################################
# Subroutines

sub init {
print<<'EOF';
/*
 *	Ohio Trollius
 *	Copyright 1996 The Ohio State University
 *	NJN
 *
 *	$Log: genwrap,v $
 *	Revision 1.0  1999/07/21 19:03:27  jsquyres
 *	Change the CVS revision number to 1.0 so that we avoid CVS's documented
 *	behavior of assigning a "dummy timestamp" to them when using CVS vis
 *	ssh (CVS only does this to 0.x revision files, we don't know why they
 *	chose to do this).  This is not the behavior that we want, so we are
 *	just changing the revision numbers to 1.0 to get around this problem.
 *
 *	Revision 0.3  1999/06/12 19:58:40  jsquyres
 *	Added $COPYRIGHT$
 *	
 *	Revision 0.2  1999/04/11 16:42:29  lamteam
 *	Add files. Fix indent.
 *	
 *	Revision 0.1  1998/02/01 13:50:41  lam
 *	initial revision
 *
 *	Function:	- profiling wrappers
 */

#undef	PROFILELIB

#ifndef PROFILEHDR
#define PROFILEHDR
#endif

#include <stdio.h>

#include <mpi.h>
#include <tstdio.h>


/*
 * Initialization/finalization routines.
 */

int
MPI_Init(pargc, pargv)

int			*pargc;
char			***pargv;

{
	int		_r;
        int             _grank;
	
	_r = PMPI_Init(pargc, pargv);

        PMPI_Comm_rank(MPI_COMM_WORLD, &_grank);
        printf("[%d]\tMPI_Init\n", _grank); fflush(stdout);

	return(_r);
}

#ifdef __STDC__
int
MPI_Pcontrol(int level, ...)
#else
int
MPI_Pcontrol(level)
int			level;
#endif
{
	int		_r;

	_r = PMPI_Pcontrol(level);

	return(_r);
}

int
MPI_Finalize()

{
	int		_r;
        int             _grank;

        PMPI_Comm_rank(MPI_COMM_WORLD, &_grank);
        printf("[%d]\tMPI_Finalize\n", _grank); fflush(stdout);

	_r = PMPI_Finalize();

	return(_r);
}

int
MPI_Initialized(pflag)

int			*pflag;

{
	int		_r;

	_r = PMPI_Initialized(pflag);

	return(_r);
}


EOF
}

########################################################################
# Some predefined trace generators
#

# simple trace of enter/exit to LAM stdio

sub preamble_trace_tstdio {
  my $c = &find_comm;
  print "\tint\t\t_grank;\n";
  print "\tint\t\t_lrank;\n" if $c;
  print "\n";
  print "\tPMPI_Comm_rank(MPI_COMM_WORLD, &_grank);\n";
  if ($c) {
    print "\tPMPI_Comm_rank($c, &_lrank);\n";
    print "\ttprintf(\"[%d/%d] starting $name ...\\n\", _grank, _lrank);\n";
  } else {
    print "\ttprintf(\"[%d] starting $name ...\\n\", _grank);\n";
  }
}
sub postamble_trace_tstdio {
  my $c = &find_comm;
  if ($c) {
    print "\ttprintf(\"[%d/%d] ending $name\\n\", _grank, _lrank);\n";
  } else {
    print "\ttprintf(\"[%d] ending $name\\n\", _grank);\n";
  }
}

# simple trace of enter/exit to stdout
 
sub preamble_trace_stdout {
  my $c = &find_comm;
  print "\tint\t\t_grank;\n";
  print "\tint\t\t_lrank;\n" if $c;
  print "\n";
  print "\tPMPI_Comm_rank(MPI_COMM_WORLD, &_grank);\n";
  if ($c) {
    print "\tPMPI_Comm_rank($c, &_lrank);\n";
    print "\tprintf(\"[%d/%d] starting $name ...\\n\", _grank, _lrank);\n";
  } else {
    print "\tprintf(\"[%d] starting $name ...\\n\", _grank);\n";
  }
}
sub postamble_trace_stdout {
  my $c = &find_comm;
  if ($c) {
    print "\tprintf(\"[%d/%d] ending $name\\n\", _grank, _lrank);\n";
  } else {
    print "\tprintf(\"[%d] ending $name\\n\", _grank);\n";
  }
}

# simple trace of enter/exit to stdout with flushing
 
sub preamble_trace_flush {
  my $c = &find_comm;
  print "\tint\t\t_grank;\n";
  print "\tint\t\t_lrank;\n" if $c;
  print "\n";
  print "\tPMPI_Comm_rank(MPI_COMM_WORLD, &_grank);\n";
  if ($c) {
    print "\tPMPI_Comm_rank($c, &_lrank);\n";
    print "\tprintf(\"[%d/%d]\\tstarting $name ...\\n\", _grank, _lrank);\n";
    print "\tfflush(stdout);\n";
  } else {
    print "\tprintf(\"[%d]\\tstarting $name ...\\n\", _grank);\n";
    print "\tfflush(stdout);\n";
  }
}
sub postamble_trace_flush {
  my $c = &find_comm;
  if ($c) {
    print "\tprintf(\"[%d/%d]\\tending $name\\n\", _grank, _lrank);\n";
    print "\tfflush(stdout);\n";
  } else {
    print "\tprintf(\"[%d]\\tending $name\\n\", _grank);\n";
    print "\tfflush(stdout);\n";
  }
}

########################################################################
# Don't customize below here unless you really know what you are doing!
#

# given file name of file containing MPI function generate a profiling
# wrapper for the function
#
sub wrap {
  my ($f) = @_;
  
  if (open(IN, "$f")) {
    print STDERR "Wrapping \"$f\"\n";

    while ($_ = <IN>) {
      last if /^(int|double)\s*$/;
    }

    &funchead;
    &body($f);
    &functail;
    print "\n\n";
  }
  else {
    print STDERR "ERROR: cannot open $f\n";
  }
}

#
# output code to make the call of the PMPI... version of the function
#
# accepts: $name	- function name
#        : $arglist     - the argument list
#
sub pmpicall {
  my ($pos, $len1, $len2, $indent);

  $len1 = 8 + 6 + length($name) + 1;
  $len2 = length($arglist) + 1;
  
  if ($len1 + $len2 > 79) {
#
# too long for one line
#
    $indent = 16;
    $pos = 0;
    while (($pos = index($arglist, ",", $pos)) >= 0) {
      if (($indent + $len2 - $pos) < 78) {
	print "\t_r = P$name", substr($arglist, 0, $pos + 1), "\n";
	print " " x $indent;
	print substr($arglist, $pos + 1), ";\n";
	last;
      }
      $pos++;
    }
  }
  else {
    print "\t_r = P$name$arglist;\n";
  }
}

sub body {
  &$preamble;  print "\n";
  &pmpicall;   print "\n";
  &$postamble; print "\n";
}


sub find_comm {
  my ($comm, $i);
  my $ncomm = 0;
  
  for ($i = 0; $i < scalar(@arg); $i++) {
    if (($dtyp[$i] eq "MPI_Comm") && ($arg[$i] !~ /\*/)) {
      $ncomm++;
      $comm = $arg[$i];
    }
  }

  if ($ncomm == 1) {
    return $comm;
  }
  else {
    if ($ncomm > 1) {
      print STDERR "WARNING: $name: ambiguous local communicator argument\n";
    }
    return "";
  }
}

#
# parses function header and outputs code for it plus the
# definition of the return variable
#
sub funchead {
#
# get the function return type
#
  my ($rettype, $nargs);
  
  ($rettype) = /^(int|double)\s*$/;
  print;
  $_ = <IN>;
  print;
#
# get the function name and arglist
#
  ($name,$arglist) = /^(\w+)(.*)/;

  while (! /\)/) {
#
# arglist span multiple lines
#
    $_ = <IN>;
    print;
    ($a) = /\s*(.*)/;
    $arglist .= " $a";
  }
#
# get arg declarations
# arg names are put in @arg, and their types in parallel array @dtyp
#
  $nargs = 0; @arg = (); @dtyp = ();
  while ($_ = <IN>) {
    print;

    if (/\w+/) {
      ($t,$n) = /(\w+)\s+(\w+)/;
      $arg[$nargs] = $n;
      $dtyp[$nargs] = $t;
      $nargs++;
    }

    last if /^{/;
  }
#
# output code to define the return variable    
#
  print "\t$rettype\t\t_r;\n";		
}

#
# output code to end off the function
#
sub functail {
  print "\treturn(_r);\n";
  print "}\n";
}