#!/usr/bin/env perl
# (C) 2011 by Argonne National Laboratory.
#     See COPYRIGHT in top-level directory.

# This script scavenges the MPICH source tree looking for "subconfigure.m4"
# files.  It then analyzes the dependencies between them and emits a
# "subsys_include.m4" file that "m4_include"s them all in the correct order and
# writes an autoconf macro that is suitable for expanding subsys macros in the
# correct order.
#
# Finding a "dnl MPICH_SUBCFG_BEFORE=BAR" statement inside of
# FOO/subconfigure.m4 means that FOO depends on BAR and that FOO's macros should
# be emitted *before* BAR's macros so that FOO can influence BAR's
# configuration.
#
# Finding a "dnl MPICH_SUBCFG_AFTER=QUUX" statement inside of
# BAZ/subconfigure.m4 means that BAZ uses QUUX and that BAZ's macros be emitted
# *after* QUUX's macros so that BAZ can utilize information exported by QUUX's
# configuration macros.
#
# We have both forms of macros because some subsystems know their consumers
# explicitly and some packages only know what they consume explicitly, and some
# packages are a blend.  For example, ch3 depends on the mpid/common/sched code
# in order to support NBC ops so a BEFORE statement is used in the
# ch3/subconfigure.m4 in order to "enable_mpid_common_sched=yes".  The nemesis
# netmods all depend on the core nemesis configuration happening first, so they
# use an AFTER statement in each of their subconfigure.m4 files.

################################################################################
use strict;
use warnings;

use Getopt::Long;
use Data::Dumper;

################################################################################
# Default global settings and constants

# unlikely to change, since this name is assumed in lots of other pieces of the
# build system
my $SUBCFG_NAME = "subconfigure.m4";
my $OUTPUT_FILE = "subsys_include.m4";

# if true, add a dependency (ancestor-->child) when $SUBCFG_NAME files are
# encountered and they have an ancestor $SUBCFG_NAME file in an enclosing
# directory
my $USE_IMPLICIT_EDGES = 1;

# the existence of this file means we should stop recursing down
# the enclosing directory tree
my $stop_sentinel = ".no_subcfg_recursion";

# which directories should be recursively searched for "subconfigure.m4" files
my @root_dirs = qw( src );

# coloring constants for the graph algorithms later on
my ($WHITE, $GRAY, $BLACK) = (1, 2, 3);

################################################################################
# Option processing: here's a great place to permit overriding the default
# global settings from above if we ever need to in the future.

my $do_bist = 0;
GetOptions(
    "--help" => \&print_usage,
    "--bist" => \$do_bist,
) or die "unable to process options, stopped";

sub print_usage {
    print <<EOT;
This script builds '$OUTPUT_FILE' from '$SUBCFG_NAME' files.

Usage: $0 [--help] [--bist]

    --bist - Run simple self tests on this script.
    --help - This message.
EOT
    exit 0;
}

if ($do_bist) {
    bist();
}

################################################################################
# preorder traverse the root dirs looking for files named $SUBCFG_NAME

# stack for recursion, contains dirs that must yet be visited
my @dirstack = ( @root_dirs );
# Parallel stack that keeps track of the nearest ancestor with a subconfigure.m4
# file.  All root dirs have no ancestors.
my @anc_stack = map { '' } @root_dirs;

# keys are the full path to the found file, value is the nearest ancestor (in
# the directory hierarchy sense) subconfigure.m4 file, or '' if none exists.
my %found_files = ();

while (my $dir = pop @dirstack) {
    my $anc = pop @anc_stack;

    # check for a $SUBCFG_NAME before recursing in order to correctly propagate
    # ancestor information for subdirectories
    my $fp = "$dir/$SUBCFG_NAME";
    if (-e $fp) {
        # found a subconfigure.m4 file
        $found_files{$fp} = $anc;
        # override our parent's ancestor for all of our descendants
        $anc = $fp;
    }

    if (-e "$dir/$stop_sentinel") {
        # the existence of this file means we should stop recursing down
        # this particular directory tree
        next;
    }

    # now that we've visited the current vertex, push all of our child dirs onto
    # the stack to continue the traversal
    opendir DH, $dir
        or die "unable to open dir='$dir', stopped";
    my @contents = sort readdir DH;
    foreach my $f (@contents) {
        # avoid endless recursion
        next if $f eq "." || $f eq "..";

        if (-d "$dir/$f") {
            push @dirstack, "$dir/$f";
            push @anc_stack, $anc;
        }
    }
    closedir DH;
}

################################################################################
# We now have a list of all $SUBCFG_NAME files in @found_files.  Process each of
# the files and build a DAG.

# A DAG where the vertices are full path filenames for $SUBCFG_NAME files and the
# edges are dependencies between the $SUBCFG_NAME files (A-->B indicates that
# A should come before B in a topo sort).  We concretely express this DAG as an
# adjacency list stored in a hash.  Keys of the hash are filenames, values are
# refs to hashes whose keys are outbound edge filenames.
# IOW:
#     ( a => {b=>1,c=>1}, b => {c=>1}, c => {} )
# represents the following (crudely drawn) graph:
#     a-->b-->c
#      \------^
my %dag = ();

# Helper routine, adds a new edge to the given dag hash (passed by reference),
# automatically creating src or dst vertices as necessary.  A cute bit of calling
# syntax is that the src and dst args can be separated by "=>" because it's just
# a fancy comma in perl.
sub add_edge {
    my $dag_ref = shift;
    my $src = shift;
    my $dst = shift;

    die "\$dag_ref is invalid, stopped" unless ref($dag_ref) eq "HASH";
    die "\$src is invalid, stopped" unless $src;
    die "\$dst is invalid, stopped" unless $dst;

    $dag_ref->{$src} = {} unless exists $dag_ref->{$src};
    $dag_ref->{$src}->{$dst} = 1;
}

foreach my $k (keys %found_files) {
    # add the vertex to the graph with no edges to start
    $dag{$k} = {} unless exists $dag{$k};

    my $anc = $found_files{$k};
    if ($anc and $USE_IMPLICIT_EDGES) {
        # need to add the implicit edge from the ancestor to $k
        add_edge(\%dag, $anc => $k);
    }

    # now process the file and add any explicit edges
    open FILE, '<', $k;
    while (my $line = <FILE>) {
        if ($line =~ m/^\s*dnl +MPICH_SUBCFG_([A-Z_]*)=(.*)\s*$/) {
            my $bef_aft = $1;
            my $arg = $2;

            # users can set GEN_SUBCFG_NO_ERROR=1 in the environment to prevent
            # this script from complaining about missing '/' chars
            if ($arg !~ m|/| and not $ENV{GEN_SUBCFG_NO_ERROR}) {
                print "ERROR: no '/' characters detected in '$arg', possible old-style structured comment still present\n";
                exit 1;
            }

            # normalize the $arg to match our DAG
            $arg .= "/$SUBCFG_NAME";

            if ($bef_aft eq "BEFORE") {
                add_edge(\%dag, $k => $arg);
            }
            elsif ($bef_aft eq "AFTER") {
                add_edge(\%dag, $arg => $k);
            }
            else {
                die "unrecognized structured comment ('MPICH_SUBCFG_${bef_aft}')\n".
                    "at $k:$., possible typo?  Stopped";
            }
        }
    }
    close FILE;
}

################################################################################
# We now have a DAG expressing the dependency information between the various
# subconfigure.m4 files.  Now we need to topologically sort it.
# 
# We use the topo sort algorithm given in "Introduction to Algorithms" (1st
# ed.), page 486 with a small modification to detect cycles in the digraph.  We
# perform a DFS on the DAG, coloring vertices as we go.  We could compute
# discovery and finishing times, as well as predecessors, but we don't need that
# information for topological sorting or cycle detection.  As each vertex is
# finished (colored BLACK) we prepend it to an array.  The resulting array is
# sorted in "ascending" topological order (a,b,c in our previous example).

# the output array in which the sorted results will be stored
my @tsorted = ();
topo_sort(\%dag, \@tsorted);

################################################################################
# Now just emit the $OUTPUT_FILE in the correct format.

open OUTFD, '>', $OUTPUT_FILE;

my $datestamp = scalar(localtime);

print OUTFD <<EOT;
dnl generated by $0 at $datestamp
dnl DO NOT EDIT BY HAND!!!
dnl re-run ./maint/updatefiles instead

EOT
foreach my $file (@tsorted) {
    print OUTFD "m4_include([$file])\n";
}
print OUTFD <<EOT;

dnl a macro suitable for use as m4_map([some_unary_macro],[PAC_SUBCFG_MODULE_LIST])
m4_define([PAC_SUBCFG_MODULE_LIST],
m4_dquote(
EOT

foreach my $file (@tsorted[0 .. $#tsorted-1]) {
    my $mod_name = $file;
    $mod_name =~ s+/$SUBCFG_NAME$++;
    $mod_name =~ tr+/+_+;
    print OUTFD "[$mod_name],\n";
}
my $mod_name = $tsorted[-1];
$mod_name =~ s+/$SUBCFG_NAME$++g;
$mod_name =~ tr+/+_+;
print OUTFD "[$mod_name]dnl <--- this dnl is important\n";
print OUTFD "))\n\n";

close OUTFD;


################################################################################
# SUBROUTINES
################################################################################

# The DFS-Visit(u) algorithm specialized for topo sorting.  Currently a
# subroutine to permit recursive invocation, but could be converted to use an
# explicit stack and the subroutine could be eliminated.
#
# takes four arguments: a ref to the DAG hash, a ref to a colors hash, the
# vertex $u, and an output array reference to be populated as vertices are
# finished.
sub dfs_visit {
    my $dag_ref = shift;
    my $colors_ref = shift;
    my $u = shift;
    my $out_arr_ref = shift;

    $colors_ref->{$u} = $GRAY;
    foreach my $v (keys %{$dag_ref->{$u}}) {
        # detect cycles in the graph at this point, see ("Classification of edges"
        # in CLR)
        if ((exists $colors_ref->{$v}) && $colors_ref->{$v} == $GRAY) {
            # We are already exploring the tree from $v, so this is a "back edge",
            # indicating a cycle is present in the digraph.  This is erroneous in
            # our usage, since we cannot topologically sort a cyclic graph.
            die "A back edge was found in the digraph but a DAG is required.\n".
                "The back edge was from\n".
                "  $u\n".
                "to\n".
                "  $v\n".
                "Stopped";
        }
        elsif ((exists $colors_ref->{$v}) && $colors_ref->{$v} == $WHITE) {
            dfs_visit($dag_ref, $colors_ref, $v, $out_arr_ref);
        }
    }
    $colors_ref->{$u} = $BLACK;

    # append $u to the output
    unshift @$out_arr_ref, $u;
}

# Takes two arguments, a ref to a DAG hash and a reference to an output array.
# Returns in the output array a valid topological sort of the given DAG.
sub topo_sort {
    my $dag_ref = shift;
    my $out_arr_ref = shift;

    # helper hash that is indexed by vertex name in order to avoid building a
    # complicated set of nested structures inside the main DAG
    my $colors_ref = {}; # values are one of $WHITE, $GRAY, or $BLACK

    # a simplified version of the DFS(G) algorithm
    foreach my $u (keys %$dag_ref) {
        $colors_ref->{$u} = $WHITE;
    }
    foreach my $u (keys %$dag_ref) {
        if ($colors_ref->{$u} == $WHITE) {
            dfs_visit($dag_ref, $colors_ref, $u, $out_arr_ref);
        }
    }
}

################################################################################
# self tests

# run this subroutine to self-test portions of this script
sub bist {
    bist_topo_sort();
    print "all self-tests PASSED\n";
    exit 0;
}

sub bist_topo_sort {
    my $dag;
    my $out_arr;
    my $expected;

    $dag = { a => {b=>1,c=>1}, b => {c=>1}, c => {} };
    $out_arr = [];
    $expected = [ qw(a b c) ];
    topo_sort($dag, $out_arr);
    cmp_arrays($out_arr, $expected);

    $dag = { a => {}, b => {}, c => {} };
    $out_arr = [];
    topo_sort($dag, $out_arr);
    # this DAG has no single expected result, so just check lengths
    unless (scalar @$out_arr eq scalar @$expected) {
        die "\$out_arr and \$expected differ in length, stopped\n";
    }

    my $routine = (caller(0))[3];
    print "$routine PASSED\n";
}

sub cmp_arrays {
    my $out_arr = shift;
    my $expected = shift;

    #print "out_arr=".Dumper($out_arr)."\n";
    #print "expected=".Dumper($expected)."\n";
    unless (scalar @$out_arr eq scalar @$expected) {
        die "\$out_arr and \$expected differ in length, stopped\n";
    }
    for (my $i = 0; $i < @$out_arr; ++$i) {
        unless ($out_arr->[$i] eq $expected->[$i]) {
            die "element $i of \$out_arr differs from the expected value (".
                $out_arr->[$i]." ne ".$expected->[$i]."), stopped\n";
        }
    }
}