#!/usr/bin/env perl
#
# Copyright (c) 2014-2015 Cisco Systems, Inc.  All rights reserved.
# Copyright (c) 2015-2021 Research Organization for Information Science
#                         and Technology (RIST).  All rights reserved.
# Copyright (c) 2022      IBM Corporation.  All rights reserved.
# $COPYRIGHT$
#
# Script to generate the overloaded MPI_SIZEOF interfaces and
# subroutine bodies for both the mpi and mpi_f08 modules.
#
# This script won't really be necessary (i.e., be a whole lot simpler)
# when Fortran compilers uniformly supprort TS 29113 -- i.e., they
# support dimension(..).  Using dimension(..), you can have just *one*
# procedure for every type, and dimension(..) will resolve to both
# scalars and all possible ranks.
#
# But for the meantime, we generate for all ranks so that we support
# as many compilers as possible.  :-\ (we don't check the compiler and
# see if it supports dimension(..) and do a different generation based
# on that, because we already have a zillion different options in the
# Fortran support -- let's just do MPI_Sizeof this one way in the name
# of simplicity...).
#

use strict;

use Getopt::Long;

my $header_arg;
my $impl_arg;
my $ierror_arg;
my $maxrank_arg;
my $generate_arg;
my $mpi_arg;
my $mpi_real2;
my $mpi_iso_real16;
my $mpi_real16;
my $mpi_complex4;
my $mpi_complex32;
my $pmpi_arg;
my $help_arg = 0;
my $request_deprecate = 0;
my $mpi_version = 0;

&Getopt::Long::Configure("bundling");
my $ok = Getopt::Long::GetOptions("complex32=i" => \$mpi_complex32,
                                  "complex4=i" => \$mpi_complex4,
                                  "header=s" => \$header_arg,
                                  "impl=s" => \$impl_arg,
                                  "ierror=s" => \$ierror_arg,
                                  "maxrank=s" => \$maxrank_arg,
                                  "generate=i" => \$generate_arg,
                                  "mpi" => \$mpi_arg,
                                  "pmpi" => \$pmpi_arg,
                                  "real16=i" => \$mpi_real16,
                                  "real2=i" => \$mpi_real2,
                                  "iso_real16=i" => \$mpi_iso_real16,
                                  "request_deprecate=i" => \$request_deprecate,
                                  "mpi_version=i" => \$mpi_version,
                                  "help|h" => \$help_arg);

die "Must specify header and/or impl filenames to output"
    if (!defined($header_arg) && !defined($impl_arg));
die "ierror handling must be optional or mandatory"
    if (defined($generate_arg) && $generate_arg &&
        (lc($ierror_arg) ne "optional" && lc($ierror_arg) ne "mandatory"));
die "max array rank must be >= 4 and <=15"
    if (defined($generate_arg) && $generate_arg &&
        (!defined($maxrank_arg) || $maxrank_arg < 4 || $maxrank_arg > 15));
die "Must specify --pmpi and/or --mpi if --impl is specified"
    if (defined($generate_arg) && $generate_arg &&
        (defined($impl_arg) && !defined($mpi_arg) && !defined($pmpi_arg)));
die "Must specify real2, iso_real16, real16, complex4, and complex32"
    if (!defined($mpi_real2) || !defined($mpi_iso_real16) || !defined($mpi_real16) ||
        !defined($mpi_complex4) || !defined($mpi_complex32));

#############################################################################

my $optional_ierror_param;
my $optional_ierror_statement;
if (lc($ierror_arg) eq "optional") {
    $optional_ierror_param = ", OPTIONAL";
    $optional_ierror_statement = "IF (present(ierror)) ";
}

my $indent = "      ";

#############################################################################

my $subs;

sub queue_sub {
    my ($f_type, $suffix, $import_type) = @_;

    # Leave off the MPI/PMI prefix; we'll add that when outputting
    my $sub_name = "Sizeof_$suffix";

    # Make a hash for this subroutine
    my $subr;
    $subr->{name} = $sub_name;
    my $start = "${indent}SUBROUTINE ^PREFIX^$sub_name^RANK^(x, size, ierror)\n";
    $start .= "${indent}  USE, INTRINSIC :: iso_fortran_env, ONLY: " . uc($import_type) . "\n"
        if (defined($import_type));
    # For long type names and large ranks, this first line gets very
    # long and only narrowly squeezed in before 72 columns.  Use no
    # whitespace.
    $start .= $indent . uc($f_type) . "^DIMENSION^::x
${indent}  INTEGER, INTENT(OUT) :: size
${indent}  INTEGER$optional_ierror_param, INTENT(OUT) :: ierror";
    $subr->{start} = $start;
    $subr->{middle} = "${indent}  size = storage_size(x) / 8
${indent}  ${optional_ierror_statement}ierror = 0";
    if (($mpi_version >= 4) && ($request_deprecate == 1)) {
        $subr->{end} = "!GCC\$ ATTRIBUTES DEPRECATED :: ^PREFIX^$sub_name^RANK^\n";
    }
    else {
        $subr->{end} = "";
    }
    $subr->{end} .= "${indent}END SUBROUTINE ^PREFIX^$sub_name^RANK^";

    # Save it in the overall hash
    $subs->{$sub_name} = $subr;
}

sub generate {
    my ($prefix, $sub_name, $rank, $want_body) = @_;

    my $subr;
    # Deep copy
    %{$subr} = %{$subs->{$sub_name}};

    # Make the initial version
    my $str = $subr->{start} . "\n";
    $str .= "\n" . $subr->{middle} . "\n"
        if ($want_body);
    $str .= $subr->{end} . "\n";

    # Substitute in the relevant parameters
    $str =~ s/\^PREFIX\^/$prefix/g;

    # If rank is 0, generate a scalar version.  Otherwise, generate an
    # array version.
    if (0 == $rank) {
        $str =~ s/\^RANK\^/_scalar/g;
        $str =~ s/\^DIMENSION\^//;
    } else {
        $str =~ s/\^RANK\^/_r$rank/g;
        my $dim;
        my $d = $rank;
        while ($d > 1) {
            $dim .= "1,";
            --$d;
        }
        $str =~ s/\^DIMENSION\^/, DIMENSION($dim*)/;
    }

    # All done
    return $str;
}

#############################################################################
# Main
#############################################################################

for my $size (qw/8 16 32 64/) {
    queue_sub("integer(int${size})", "int${size}", "int${size}");
}
for my $size (qw/16 32 64 128/) {
    if (!($size == 16 && $mpi_real2 == 0 && $mpi_iso_real16 == 0) &&
        !($size == 128 && $mpi_real16 == 0)) {
        queue_sub("real(real${size})", "real${size}", "real${size}");
    }
    if (!($size == 16 && $mpi_complex4 == 0 && $mpi_iso_real16 == 0) &&
        !($size == 128 && $mpi_complex32 == 0)) {
        queue_sub("complex(real${size})", "complex${size}", "real${size}");
    }
}
if ($mpi_real2 == 1 && $mpi_iso_real16 == 0) {
    queue_sub("real*2", "real16");
    queue_sub("complex*4", "complex16");
}
queue_sub("character", "character");
queue_sub("logical", "logical");

#######################################################

sub output_content {
    my ($prefix, $want_bodies) = @_;

    print OUT "${indent}INTERFACE ${prefix}Sizeof\n\n"
        if (!$want_bodies);

    # Print all the module procedure lines
    foreach my $sub_name (sort(keys(%{$subs}))) {
        my $rank = 0;
        while ($rank <= $maxrank_arg) {
            my $str = generate($prefix, $sub_name, $rank, $want_bodies);
            print OUT $str . "\n";
            ++$rank;
        }
    }

    print OUT "${indent}END INTERFACE ${prefix}Sizeof\n\n"
        if (!$want_bodies);
}

# Output each file
sub output_file {
    my ($filename, $want_bodies) = @_;

    unlink($filename);
    open(OUT, ">$filename") || die "Can't open $filename for writing";
    print OUT "! -*- f90 -*-
! WARNING: This is a generated file!  Edits will be lost!
!
! Copyright (c) 2014 Cisco Systems, Inc.  All rights reserved.
! \$COPYRIGHT\$
!
! This file was generated by gen-mpi-sizeof.pl for all the MPI_SIZEOF
! interface possibilities for intrinsic types.  Once TS 29113 is
! supported in all compilers, we can simply have *one* procedure for
! each type and use dimension(..) to indicate scalars+all array ranks.
! But until more compilers support this, we simply generate a
! procedure for scalars and all possible ranks in an attempt to
! support lots of Fortran compilers.\n\n";

    # Only output if the generate arg is 0.  Otherwise, output an
    # empty .h file (that is still safe to include by mpif.h, but
    # won't include the MPI_SIZEOF interface block).
    if ($generate_arg) {
        output_content("MPI_", $want_bodies)
            if (!$want_bodies ||
                ($want_bodies && $mpi_arg));
        output_content("PMPI_", $want_bodies)
            if (!$want_bodies ||
                ($want_bodies && $pmpi_arg));
    } else {
        print OUT "! *** ATTENTION!
!
! Sad panda.
!
! This compiler does not support the Right Stuff to enable MPI_SIZEOF.
! Specifically: we need support for the INTERFACE keyword,
! ISO_FORTRAN_ENV, and the STORAGE_SIZE() intrinsic on all types.
! Apparently, this compiler does not support both of those things, so
! this file will be (effectively) blank (i.e., we didn't bother
! generating the necessary stuff for MPI_SIZEOF because the compiler
! doesn't support
! it).
!
! If you want support for MPI_SIZEOF, please use a different Fortran
! compiler to build Open MPI.\n\n";

        if ($want_bodies) {
            my $name =  $pmpi_arg ? "pompi_sad_panda" : "ompi_sad_panda";
            print OUT "!
! Dummy subroutine, just so that there is *some* Fortran in this file
! (this is defensive programming: since the Fortran compiler doesn't
! support enough mojo, configure should set some AM_CONDITIONALs such
! that this file should not end up being compiled, but just in case
! that logic changes someday and this file *does* end up getting
! compiled, make sure that it's not entirely empty because some
! compilers are unhappy if there are no Fortran statements in this
! file).
subroutine $name()
  implicit none

  print *, 'Open MPI is a sad panda because your Fortran compiler'
  print *, 'does not support enough Fortran mojo for MPI_SIZEOF'
end subroutine $name\n\n";
        }
    }

    close(OUT);
}

output_file($header_arg, 0)
    if (defined($header_arg));
output_file($impl_arg, 1)
    if (defined($impl_arg));

exit(0);