openmp/runtime/tools/lib/Build.pm

#
#//===----------------------------------------------------------------------===//
#//
#//                     The LLVM Compiler Infrastructure
#//
#// This file is dual licensed under the MIT and the University of Illinois Open
#// Source Licenses. See LICENSE.txt for details.
#//
#//===----------------------------------------------------------------------===//
#
package Build;

use strict;
use warnings;

use Cwd qw{};

use LibOMP;
use tools;
use Uname;
use Platform ":vars";

my $host = Uname::host_name();
my $root = $ENV{ LIBOMP_WORK    };
my $tmp  = $ENV{ LIBOMP_TMP     };
my $out  = $ENV{ LIBOMP_EXPORTS };

my @jobs;
our $start = time();

# --------------------------------------------------------------------------------------------------
# Helper functions.
# --------------------------------------------------------------------------------------------------

# tstr -- Time string. Returns string "yyyy-dd-mm hh:mm:ss UTC".
sub tstr(;$) {
    my ( $time ) = @_;
    if ( not defined( $time ) ) {
        $time = time();
    }; # if
    my ( $sec, $min, $hour, $day, $month, $year ) = gmtime( $time );
    $month += 1;
    $year  += 1900;
    my $str = sprintf( "%04d-%02d-%02d %02d:%02d:%02d UTC", $year, $month, $day, $hour, $min, $sec );
    return $str;
}; # sub tstr

# dstr -- Duration string. Returns string "hh:mm:ss".
sub dstr($) {
    # Get time in seconds and format it as time in hours, minutes, seconds.
    my ( $sec ) = @_;
    my ( $h, $m, $s );
    $h   = int( $sec / 3600 );
    $sec = $sec - $h * 3600;
    $m   = int( $sec / 60 );
    $sec = $sec - $m * 60;
    $s   = int( $sec );
    $sec = $sec - $s;
    return sprintf( "%02d:%02d:%02d", $h, $m, $s );
}; # sub dstr

# rstr -- Result string.
sub rstr($) {
    my ( $rc ) = @_;
    return ( $rc == 0 ? "+++ Success +++" : "--- Failure ---" );
}; # sub rstr

sub shorter($;$) {
    # Return shorter variant of path -- either absolute or relative.
    my ( $path, $base ) = @_;
    my $abs = abs_path( $path );
    my $rel = rel_path( $path, $base );
    if ( $rel eq "" ) {
        $rel = ".";
    }; # if
    $path = ( length( $rel ) < length( $abs ) ? $rel : $abs );
    if ( $target_os eq "win" ) {
        $path =~ s{\\}{/}g;
    }; # if
    return $path;
}; # sub shorter

sub tee($$) {

    my ( $action, $file ) = @_;
    my $pid = 0;

    my $save_stdout = Symbol::gensym();
    my $save_stderr = Symbol::gensym();

    # --- redirect stdout ---
    STDOUT->flush();
    # Save stdout in $save_stdout.
    open( $save_stdout, ">&" . STDOUT->fileno() )
        or die( "Cannot dup filehandle: $!; stopped" );
    # Redirect stdout to tee or to file.
    if ( $tools::verbose ) {
        $pid = open( STDOUT, "| tee -a \"$file\"" )
            or die "Cannot open pipe to \"tee\": $!; stopped";
    } else {
        open( STDOUT, ">>$file" )
            or die "Cannot open file \"$file\" for writing: $!; stopped";
    }; # if

    # --- redirect stderr ---
    STDERR->flush();
    # Save stderr in $save_stderr.
    open( $save_stderr, ">&" . STDERR->fileno() )
        or die( "Cannot dup filehandle: $!; stopped" );
    # Redirect stderr to stdout.
    open( STDERR, ">&" . STDOUT->fileno() )
        or die( "Cannot dup filehandle: $!; stopped" );

    # Perform actions.
    $action->();

    # --- restore stderr ---
    STDERR->flush();
    # Restore stderr from $save_stderr.
    open( STDERR, ">&" . $save_stderr->fileno() )
        or die( "Cannot dup filehandle: $!; stopped" );
    # Close $save_stderr.
    $save_stderr->close() or die ( "Cannot close filehandle: $!; stopped" );

    # --- restore stdout ---
    STDOUT->flush();
    # Restore stdout from $save_stdout.
    open( STDOUT, ">&" . $save_stdout->fileno() )
        or die( "Cannot dup filehandle: $!; stopped" );
    # Close $save_stdout.
    $save_stdout->close() or die ( "Cannot close filehandle: $!; stopped" );

    # Wait for the child tee process, otherwise output of make and build.pl interleaves.
    if ( $pid != 0 ) {
        waitpid( $pid, 0 );
    }; # if

}; # sub tee

sub log_it($$@) {
    my ( $title, $format, @args ) = @_;
    my $message  = sprintf( $format, @args );
    my $progress = cat_file( $tmp, sprintf( "%s-%s.log", $target_platform, Uname::host_name() ) );
    if ( $title ne "" and $message ne "" ) {
        my $line = sprintf( "%-15s : %s\n", $title, $message );
        info( $line );
        write_file( $progress, tstr() . ": " . $line, -append => 1 );
    } else {
        write_file( $progress, "\n", -append => 1 );
    }; # if
}; # sub log_it

sub progress($$@) {
    my ( $title, $format, @args ) = @_;
    log_it( $title, $format, @args );
}; # sub progress

sub summary() {
    my $total   = @jobs;
    my $success = 0;
    my $finish = time();
    foreach my $job ( @jobs ) {
        my ( $build_dir, $rc ) = ( $job->{ build_dir }, $job->{ rc } );
        progress( rstr( $rc ), "%s", $build_dir );
        if ( $rc == 0 ) {
            ++ $success;
        }; # if
    }; # foreach $job
    my $failure = $total - $success;
    progress( "Successes",      "%3d of %3d", $success, $total );
    progress( "Failures",       "%3d of %3d", $failure, $total );
    progress( "Time elapsed",   "  %s", dstr( $finish - $start ) );
    progress( "Overall result", "%s", rstr( $failure ) );
    return $failure;
}; # sub summary

# --------------------------------------------------------------------------------------------------
# Worker functions.
# --------------------------------------------------------------------------------------------------

sub init() {
    make_dir( $tmp );
}; # sub init

sub clean(@) {
    # Clean directories.
    my ( @dirs ) = @_;
    my $exit = 0;
    # Mimisc makefile -- print a command.
    print( "rm -f -r " . join( " ", map( shorter( $_ ) . "/*", @dirs ) ) . "\n" );
    $exit =
        execute(
            [ $^X, cat_file( $ENV{ LIBOMP_WORK }, "tools", "clean-dir.pl" ), @dirs ],
            -ignore_status => 1,
            ( $tools::verbose ? () : ( -stdout => undef, -stderr => "" ) ),
        );
    return $exit;
}; # sub clean

sub make($$$) {
    # Change dir to build one and run make.
    my ( $job, $clean, $marker ) = @_;
    my $dir      = $job->{ build_dir };
    my $makefile = $job->{ makefile };
    my $args     = $job->{ make_args };
    my $cwd      = Cwd::cwd();
    my $width    = -10;

    my $exit;
    $dir = cat_dir( $tmp, $dir );
    make_dir( $dir );
    change_dir( $dir );

    my $actions =
        sub {
            my $start = time();
            $makefile = shorter( $makefile );
            print( "-" x 79, "\n" );
            printf( "%${width}s: %s\n", "Started",   tstr( $start ) );
            printf( "%${width}s: %s\n", "Root dir",  $root );
            printf( "%${width}s: %s\n", "Build dir", shorter( $dir, $root ) );
            printf( "%${width}s: %s\n", "Makefile",  $makefile );
            print( "-" x 79, "\n" );
            {
                # Use shorter LIBOMP_WORK to have shorter command lines.
                # Note: Some tools may not work if current dir is changed.
                local $ENV{ LIBOMP_WORK } = shorter( $ENV{ LIBOMP_WORK } );
                $exit =
                    execute(
                        [
                            "make",
                            "-r",
                            "-f", $makefile,
                            "arch=" . $target_arch,
                            "marker=$marker",
                            @$args
                        ],
                        -ignore_status => 1
                    );
                if ( $clean and $exit == 0 ) {
                    $exit = clean( $dir );
                }; # if
            }
            my $finish = time();
            print( "-" x 79, "\n" );
            printf( "%${width}s: %s\n", "Finished", tstr( $finish ) );
            printf( "%${width}s: %s\n", "Elapsed", dstr( $finish - $start ) );
            printf( "%${width}s: %s\n", "Result", rstr( $exit ) );
            print( "-" x 79, "\n" );
            print( "\n" );
        }; # sub
    tee( $actions, "build.log" );

    change_dir( $cwd );

    # Save completed job to be able print summary later.
    $job->{ rc } = $exit;
    push( @jobs, $job );

    return $exit;

}; # sub make

1;