#!/usr/bin/env perl

use warnings;
use strict;

use Data::Dumper;
use Getopt::Long qw(:config no_ignore_case);
use File::Path qw(make_path);
use XML::Simple qw(:strict);
use JSON;

# Pull in from the lib directory
use FindBin qw($RealBin);
use FindBin qw($RealScript);
use lib "$RealBin/lib";

use BitRange;

#-------------------------------------------------------------------------------
# Global Variables
#-------------------------------------------------------------------------------

# Supported file versions and their values.
my $FILE_VERSION =
{
    VER_01 => 0x01,
};

# This is a map of all currently supported models/ECs and their IDs.
my $SUPPORTED_MODEL_EC =
{
    EXPLORER_11 => 0x60D20011, # Explorer Chip DD1.0
    EXPLORER_20 => 0x60D20020, # Explorer Chip DD1.0
    P10_10      => 0x20DA0010, # P10 Chip DD1.0
    P10_20      => 0x20DA0020, # P10 Chip DD2.0
};

# All models/ECs that may exist in the XML, but no longer needs to be built.
# This is useful for build optimization and also help prevent build breaks when
# the XML still exists, but not needed anymore.
my $DEPRECATED_MODEL_EC = [];

# Supported register types and their values.
my $REGISTER_TYPE =
{
    SCOM   => { id => 0x01, addr_size => 4, reg_size => 8 },
    IDSCOM => { id => 0x02, addr_size => 8, reg_size => 8 },
};

# Supported attention types and their values.
my $ATTN_TYPE =
{
    CS  => 1, # System checkstop hardware attention
    UCS => 2, # Unit checkstop hardware attention
    RE  => 3, # Recoverable hardware attention
    SPA => 4, # SW or HW event requiring action by the service processor FW
    HA  => 5, # SW or HW event requiring action by the host FW
};

#-------------------------------------------------------------------------------
# Help function
#-------------------------------------------------------------------------------

sub help()
{
    print <<EOF;
Usage: $RealScript -h
       $RealScript -i <input_dir> -o <output_dir>

Builds Chip Data Binary files from the input Chip Data XML.

Options:
 -h, --help     Prints this menu.
 -i, --input    Directory containing the Chip Data XML files.
 -o, --output   Directory that will contain the Chip Data Binary files.
EOF

    exit;
}

#-------------------------------------------------------------------------------
# Input
#-------------------------------------------------------------------------------

help() unless @ARGV; # print help if no arguments

# Get options
my ( $help, $src_dir, $dest_dir );
help() unless GetOptions( 'h|help'     => \$help,
                          'i|input=s'  => \$src_dir,
                          'o|output=s' => \$dest_dir );

help() if @ARGV; # print usage if there are extra arguments

# -h,--help
help() if ( $help );

# -i,--input
die "ERROR> Option -i required." unless ( defined $src_dir );
die "ERROR> '$src_dir' is not a directory" unless ( -d $src_dir );

# -o,--output
die "ERROR> Option -o required." unless ( defined $dest_dir );
make_path( $dest_dir, {error => \my $err} );
if ( @{$err} )
{
    my ( $file, $message ) = %{shift @{$err}};
    die "ERROR> $message: $file\n";
}

#-------------------------------------------------------------------------------
# Prototypes
#-------------------------------------------------------------------------------

sub importXML($);
sub normalizeXML($);
sub buildBinary($$);

#-------------------------------------------------------------------------------
# Main
#-------------------------------------------------------------------------------

# Validate and import the XML.
my $chip_data_xml = importXML( $src_dir );

# There are some fields in the XML that are shorthand and need to be expanded
# before building the binary files.
my $normalized_data = normalizeXML( $chip_data_xml );

# The XML should now be in a format to start building the binary files.
buildBinary( $dest_dir, $normalized_data );

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

sub FAIL($) { die( "ERROR> " . shift @_ ); }

#-------------------------------------------------------------------------------
# Import functions
#-------------------------------------------------------------------------------

# For each supported XML file in the given directory:
#   - Ensures the XML is well-formed.
#   - Ensures the XML validates against the schema.
#   - Imports the XML into Perl data structures.
sub importXML($)
{
    my ( $dir ) = @_;

    my $data = {};

    # Get a list of all the XML files.
    opendir DIR, $dir or die "Couldn't open dir '$dir': $!";
    my @files = grep { /^.+\.xml$/ } readdir DIR;
    closedir DIR;

    # Iterate each supported file type.
    for my $type ( "chip", "node" )
    {
        for my $file ( grep { /^$type\_.+\.xml$/ } @files )
        {
            my $path = "$dir/$file";

            # Ensure the XML is well-formed and validates against the schema.
            my $out = `xmllint --noout --schema $RealBin/$type.xsd $path 2>&1`;
            die "$out\nRAS XML validation failed on $file" if ( 0 != $? );

            # Import the XML.
            my $xml = XMLin( $path, KeyAttr => {}, ForceArray => 1 );

            # Add the file path to the XML for error output.
            $xml->{path} = $path;

            # Push each file's data to a list for each file type.
            push @{$data->{$type}}, $xml;
        }
    }

    return $data;
}

#-------------------------------------------------------------------------------
# Normalize functions
#-------------------------------------------------------------------------------

# Takes a string of models/ECs separated by ',' and returns a list of supported
# models/ECs. See $SUPPORTED_MODEL_EC and $DEPRECATED_MODEL_EC.
sub __expandModelEc($)
{
    my ( $str ) = @_;

    my @list = split(/,/, $str);

    # Remove any deprecated models/ECs.
    for my $d ( @{$DEPRECATED_MODEL_EC} )
    {
        @list = grep { $d ne $_ } @list;
    }

    # Validate the remaining models/ECs.
    for my $m ( @list )
    {
        unless ( defined $SUPPORTED_MODEL_EC->{$m} )
        {
            FAIL("Unsupported model/EC: $m");
        }
    }

    return @list;
}

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

sub __getInstRange($)
{
    my ( $insts ) = @_;

    my $list = [];
    for ( @{$insts} ) { push @{$list}, $_->{reg_inst}; }

    @{$list} = sort @{$list}; # Sort the list just in case.

    return BitRange::compress($list);
}

sub __getReg($$$$)
{
    my ( $inst_in, $reg_type, $name, $addr_mod ) = @_;

    my $inst_out = [];
    for ( @{$inst_in} )
    {
        my $addr = "";
        if ( "SCOM" eq $reg_type )
        {
            $addr = sprintf( "0x%08x", hex($_->{addr}) + $addr_mod );
        }
        elsif ( "IDSCOM" eq $reg_type )
        {
            # TODO: Need a portable way of handling 64-bit numbers.
            FAIL("IDSCOM address currently not supported");
        }
        else
        {
            FAIL("Unsupported register type for node: $name");
        }

        push @{$inst_out}, { reg_inst => $_->{reg_inst}, addr => $addr };
    }

    return { name => $name, instance => $inst_out };
}

sub __getExpr($$)
{
    my ( $name, $config ) = @_;

    # Get the register expression.
    my $expr = { type => 'reg', value1 => $name };

    if ( '0' eq $config )
    {
        # Take the NOT of the register expression.
        $expr = { type => 'not', expr => [ $expr ] };
    }

    return $expr;
}

sub __getAct($$$$)
{
    my ( $fir, $range, $type, $config ) = @_;

    FAIL("Invalid action config: $config") unless ( $config =~ /^[01]{2,3}$/ );

    my @c = split( //, $config );

    my $e = [];
    push( @{$e}, __getExpr("${fir}",      '1'     ) );
    push( @{$e}, __getExpr("${fir}_MASK", '0'     ) );
    push( @{$e}, __getExpr("${fir}_ACT0", shift @c) );
    push( @{$e}, __getExpr("${fir}_ACT1", shift @c) );
    push( @{$e}, __getExpr("${fir}_ACT2", shift @c) ) if ( 0 < scalar @c );

    return { node_inst => $range, attn_type => $type,
             expr => [ { type => 'and', expr => $e } ] };
}

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

sub __normalizeLocalFir($)
{
    my ( $node ) = @_;

    return unless ( defined $node->{local_fir} );

    # Note that the isolator will implicitly add all register referenced by the
    # rules to the capture group. To reduce redundancy and overall file size, we
    # won't add these registers to the capture group.

    $node->{register}      = [] unless ( defined $node->{register}      );
    $node->{rule}          = [] unless ( defined $node->{rule}          );

    for my $l ( @{$node->{local_fir}} )
    {
        my $n = $l->{name};
        my $i = $l->{instance};
        my $t = $node->{reg_type};

        my $inst_range = __getInstRange($i);

        my $r = [];
        push @{$r}, __getReg($i, $t, "${n}",      0);
        push @{$r}, __getReg($i, $t, "${n}_MASK", 3);
        push @{$r}, __getReg($i, $t, "${n}_ACT0", 6);
        push @{$r}, __getReg($i, $t, "${n}_ACT1", 7);
        push @{$r}, __getReg($i, $t, "${n}_WOF",  8) if ($l->{config} =~ /W/);
        push @{$r}, __getReg($i, $t, "${n}_ACT2", 9) if ($l->{config} =~ /2/);

        push @{$node->{register}}, @{$r};

        for ( @{$l->{action}} )
        {
            push @{$node->{rule}},
                 __getAct( $n, $inst_range, $_->{attn_type}, $_->{config} );
        }
    }

    delete $node->{local_fir};
}

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

# This is not very efficient, especially for large data structures. It is
# recommended to use Data::Compare, but that is not available on the pool
# machines.
sub __dirtyCompare($$)
{
    local $Data::Dumper::Terse    = 1;
    local $Data::Dumper::Indent   = 0;
    local $Data::Dumper::Sortkeys = 1;
    my ( $a, $b ) = ( Dumper(shift), Dumper(shift) );
    return $a eq $b;
}

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

sub __normalizeRegister($$)
{
    my ( $node, $regs ) = @_;

    # There must be at least one register entry.
    unless ( defined $node->{register} and 0 < scalar @{$node->{register}} )
    {
        FAIL( "Node $node->{name} does not contain at least one register" );
    }

    # All of the registers will be put in the master register list for the chip.
    for my $r ( @{$node->{register}} )
    {
        # Set the default access if needed.
        $r->{access} = 'RW' unless ( defined $r->{access} );

        # Each register will keep track of its type.
        $r->{reg_type} = $node->{reg_type};

        for my $model_ec ( __expandModelEc($node->{model_ec}) )
        {
            if ( defined $regs->{$model_ec}->{$r->{name}} )
            {
                # This register already exists so check the contents for
                # accuracy
                unless ( __dirtyCompare($r, $regs->{$model_ec}->{$r->{name}}) )
                {
                    FAIL("Duplicate register: $r->{name}");
                }
            }
            else
            {
                # Add this node's register to the master register list.
                $regs->{$model_ec}->{$r->{name}} = $r;
            }
        }
    }

    # Clean up this node's register data.
    delete $node->{register};
}

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

sub __normalizeCaptureGroup($$)
{
    my ( $node, $insts_data ) = @_;

    # Capture groups are optional (although recommended).
    return unless ( defined $node->{capture_group} );

    for my $c ( @{$node->{capture_group}} )
    {
        # There must be at least one capture_register.
        unless ( defined $c->{capture_register} and
                 0 < scalar @{$c->{capture_register}} )
        {
            FAIL("<capture_group> for node $node->{name} does not contain at " .
                 "least one <capture_register>" );
        }

        my @node_insts = BitRange::expand($c->{node_inst});

        for my $r ( @{$c->{capture_register}} )
        {
            # node_inst and reg_inst must be the same size.
            my @reg_insts = BitRange::expand($r->{reg_inst});
            unless ( scalar @node_insts == scalar @reg_insts )
            {
                FAIL("capture_group/\@node_inst and capture_register/" .
                     "\@reg_inst list sized not equal for node $node->{name}");
            }

            # Expand the capture groups so there is one per node instance.
            for ( 0 .. (scalar @node_insts - 1) )
            {
                my ( $ni, $ri ) = ( $node_insts[$_], $reg_insts[$_] );
                push @{$insts_data->{$ni}->{capture_group}},
                     { reg_name => $r->{reg_name}, reg_inst => $ri };
            }
        }
    }

    # Clean up this node's capture group data.
    delete $node->{capture_group};
}

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

sub __normalizeExpr($$$$); # Called recursively

sub __normalizeExpr($$$$)
{
    my ( $in, $ni, $idx, $size ) = @_;

    my ( $t, $e, $v1, $v2 ) = ( $in->{type}, $in->{expr},
                                $in->{value1}, $in->{value2} );

    my $out = { type => $t };

    if ( "and" eq $t or "or" eq $t )
    {
        if ( defined $v1 or defined $v2 or
             not defined $e or not (0 < scalar @{$e}) )
        {
            FAIL("Invalid parameters for and/or expression");
        }

        # Iterate each sub expression.
        push @{$out->{expr}}, __normalizeExpr($_, $ni, $idx, $size) for (@{$e});
    }
    elsif ( "not" eq $t )
    {
        if ( defined $v1 or defined $v2 or
             not defined $e or not (1 == scalar @{$e}) )
        {
            FAIL("Invalid parameters for not expression");
        }

        # Iterate each sub expression.
        push @{$out->{expr}}, __normalizeExpr($_, $ni, $idx, $size) for (@{$e});
    }
    elsif ( "lshift" eq $t or "rshift" eq $t )
    {
        if ( not defined $v1 or defined $v2 or
             not defined $e or not (1 == scalar @{$e}) )
        {
            FAIL("Invalid parameters for lshift/rshift expression");
        }

        # Copy value1.
        $out->{value1} = $v1;

        # Iterate each sub expression.
        push @{$out->{expr}}, __normalizeExpr($_, $ni, $idx, $size) for (@{$e});
    }
    elsif ( "reg" eq $t )
    {
        if ( not defined $v1 or defined $e )
        {
            FAIL("Invalid parameters for reg expression");
        }

        # Copy value1.
        $out->{value1} = $v1;

        # value2 is optional in the XML, update the value to the node or
        # register instance.
        if ( defined $v2 )
        {
            my @reg_insts = BitRange::expand($v2);
            unless ( $size == scalar @reg_insts )
            {
                FAIL("reg expression value2:$v2 list not the same ".
                     "size as containing node's rule instances:$size");
            }

            $out->{value2} = $reg_insts[$idx];
        }
        else
        {
            # The register instance is the same as the node instance.
            $out->{value2} = $ni;
        }
    }
    elsif ( "int" eq $t )
    {
        if ( not defined $v1 or defined $v2 or defined $e )
        {
            FAIL("Invalid parameters for int expression");
        }

        # Copy value1.
        $out->{value1} = $v1;
    }
    else
    {
        FAIL("Unsupported expression type: $t");
    }

    return $out;
}

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

sub __normalizeRule($$)
{
    my ( $node, $insts_data ) = @_;

    # There must be at least one rule entry.
    unless ( defined $node->{rule} and 0 < scalar @{$node->{rule}} )
    {
        FAIL( "Node $node->{name} does not contain at least one rule" );
    }

    # There should be only one rule per attention type and node instance for
    # this node.
    my $rule_dups = {};

    for my $r ( @{$node->{rule}} )
    {
        # There should be exactly one parent expression.
        unless ( 1 == scalar @{$r->{expr}} )
        {
            FAIL("Multiple parent expressions for rule: $node->{name} " .
                 "$r->{attn_type}");
        }
        my $expr = $r->{expr}->[0];

        my @node_insts = BitRange::expand($r->{node_inst});
        my $sz_insts = scalar @node_insts;

        # Expand the expression for each node instance.
        for my $idx ( 0 .. ($sz_insts - 1) )
        {
            my $ni = $node_insts[$idx];

            # Check for duplicates.
            if ( defined $rule_dups->{$r->{attn_type}}->{$ni} )
            {
                FAIL("Duplicate rule: $node->{name} $r->{attn_type} $ni");
            }
            else
            {
                $rule_dups->{$r->{attn_type}}->{$ni} = 1;
            }

            # Add the rule for this expression.
            push @{$insts_data->{$ni}->{rule}},
                 { attn_type => $r->{attn_type},
                   expr      => __normalizeExpr($expr, $ni, $idx, $sz_insts) };
        }
    }

    # Clean up this node's rule data.
    delete $node->{rule};
}

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

sub __normalizeBit($$$)
{
    my ( $node, $sigs, $insts_data ) = @_;

    # There must be at least one bit entry.
    unless ( defined $node->{bit} and 0 < scalar @{$node->{bit}} )
    {
        FAIL( "Node $node->{name} does not contain at least one bit" );
    }

    my @node_insts = sort keys %{$insts_data};
    my $sz_insts = scalar @node_insts;

    # There should be only one child node per node instance bit position.
    my $child_dups = {};

    for my $b ( sort {$a->{pos} cmp $b->{pos}} @{$node->{bit}} )
    {
        my @child_insts = ();

        # Ensure child_node and node_inst are set properly.
        if ( defined $b->{child_node} )
        {
            # Ensure each bit has a default node_inst attribute if needed.
            $b->{node_inst} = "0" unless ( defined $b->{node_inst} );

            # Get all of the instances for this child node.
            @child_insts = BitRange::expand($b->{node_inst});

            # Both inst list must be equal in size.
            unless ( $sz_insts == scalar @child_insts )
            {
                FAIL("node_inst attribute list size for node:$node->{name} " .
                     "bit:$b->{pos} does not match node instances " .
                     "represented by the <rule> element");
            }
        }
        elsif ( defined $b->{node_inst} )
        {
            FAIL("node_inst attribute exists for node:$node->{name} " .
                 "bit:$b->{pos} with no child_node attribute");
        }

        # Get the signatures for each node, instance, and bit position.
        for my $p ( BitRange::expand($b->{pos}) )
        {
            for my $i ( 0 .. ($sz_insts-1) )
            {
                my ( $n, $ni ) = ( $node->{name}, $node_insts[$i] );

                # This is to cover a bug in the figtree information where there
                # currently is no comment for some bits.
                $b->{content} = "" unless ( defined $b->{content} );

                for my $model_ec ( __expandModelEc($node->{model_ec}) )
                {
                    # Check if this signature already exists.
                    if ( defined $sigs->{$model_ec}->{$n}->{$ni}->{$p} and
                        $b->{content} ne $sigs->{$model_ec}->{$n}->{$ni}->{$p} )
                    {
                        FAIL("Duplicate signature for $n $ni $p");
                    }

                    # Get the signatures for each node, instance, and bit
                    # position.
                    $sigs->{$model_ec}->{$n}->{$ni}->{$p} = $b->{content};
                }

                # Move onto the next instance unless a child node exists.
                next unless ( defined $b->{child_node} );

                my $pi = $child_insts[$i];

                my $child = { pos        => $p,
                              child_node => $b->{child_node},
                              node_inst  => $pi };

                # Ensure this child node doesn't already exist.
                if ( defined $child_dups->{$ni}->{$p} and
                     not __dirtyCompare($child, $child_dups->{$ni}->{$p}) )
                {
                    FAIL("Duplicate child_node for $n $ni $p");
                }

                # Add this child node.
                push @{$insts_data->{$ni}->{bit}}, $child;
            }
        }
    }

    # Clean up this node's bit data.
    delete $node->{bit};
}

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

sub __normalizeNode($$$)
{
    my ( $node, $regs, $sigs ) = @_;

    # Ensure a valid register type.
    unless ( grep { /^$node->{reg_type}$/ } keys %{$REGISTER_TYPE} )
    {
        FAIL( "Unsupported register type: $node->{reg_type}" );
    }

    my $insts_data = {}; # Collect data for each instance of this node.

    # First, expand the <local_fir> data if it exists.
    __normalizeLocalFir($node);

    # All registers will be put in a master register list for the chip.
    __normalizeRegister($node, $regs);

    # Split the capture group information per node instance.
    __normalizeCaptureGroup($node, $insts_data);

    # Split the rule information per node instance. The sorted instance list
    # will be used as indexes for the node_inst attribute of the <bit> elements.
    __normalizeRule($node, $insts_data);

    # Finally, collect the signature details and split the bit information per
    # node instance.
    __normalizeBit($node, $sigs, $insts_data);

    # Now that we have all of the node data, collapse the instance data into
    # a list.
    for ( sort keys %{$insts_data} )
    {
        $insts_data->{$_}->{node_inst} = $_;
        push @{$node->{instance}}, $insts_data->{$_};
    }
}

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

sub normalizeXML($)
{
    my ( $xml ) = @_;

    my $data = {};

    # Iterate each chip file.
    for my $chip ( @{$xml->{chip}} )
    {
        # Iterate each model/EC.
        for my $model_ec ( __expandModelEc($chip->{model_ec}) )
        {
            # Ensure there is not a duplicate definition for a model/EC.
            if ( $data->{$model_ec}->{chip} )
            {
                FAIL("Duplicate data for model/EC $model_ec in:\n" .
                     "    $data->{$model_ec}->{chip}->{path}\n" .
                     "    $chip->{path}");
            }

            # Add this chip to the data.
            $data->{$model_ec}->{attn_tree} = $chip->{attn_tree};
        }
    }

    # Extract the data for each node.
    my ( $regs, $sigs, $node_dups ) = ( {}, {}, {} );
    for my $node ( sort { $a->{name} cmp $b->{name} } @{$xml->{node}} )
    {
        # A node may be defined for more than one model/EC.
        for my $model_ec ( __expandModelEc($node->{model_ec}) )
        {
            # A node can only be defined once per model/EC.
            if ( defined $node_dups->{$model_ec}->{$node->{name}} )
            {
                FAIL( "Duplicate node defined for $model_ec -> $node->{name} ");
            }
            else
            {
                $node_dups->{$model_ec}->{$node->{name}} = 1;
            }

            # Initialize the master list of registers and signatures of this
            # model/EC, if necessary.

            $regs->{$model_ec} = {} unless ( defined $regs->{$model_ec} );
            $sigs->{$model_ec} = {} unless ( defined $sigs->{$model_ec} );
        }

        # The same node content will be used for each model/EC characterized by
        # this node. There is some normalization that needs to happen because of
        # shorthand elements, like <local_fir>, and some error checking. This
        # only needs to be done once per node, not per model/EC.
        __normalizeNode( $node, $regs, $sigs );

        # Push the node data for each model/EC.
        for my $model_ec ( __expandModelEc($node->{model_ec}) )
        {
            push @{$data->{$model_ec}->{node}}, $node;
        }
    }

    # Sort and collapse the master register list.
    for my $m ( keys %{$regs} )
    {
        for my $n ( sort keys %{$regs->{$m}} )
        {
            push @{$data->{$m}->{register}}, $regs->{$m}->{$n};
        }
    }

    # Collapse the signature lists.
    for my $m ( keys %{$sigs} )
    {
        for my $n ( sort keys %{$sigs->{$m}} )
        {
            for my $i ( sort {$a <=> $b} keys %{$sigs->{$m}->{$n}} )
            {
                for my $b ( sort {$a <=> $b} keys %{$sigs->{$m}->{$n}->{$i}} )
                {
                    push @{$data->{$m}->{signature}},
                         { name => $n, inst => $i, bit => $b,
                           desc => $sigs->{$m}->{$n}->{$i}->{$b} };
                }
            }
        }
    }

    return $data;
}

#-------------------------------------------------------------------------------
# Output functions
#-------------------------------------------------------------------------------

# The $num passed into this function can be a numeric of string. All values are
# converted to a hex string and then into the binary format. This helps avoid
# portability issues with endianess. Requirements:
#  - Hex strings must start with '0x'.
#  - For portability, 64-bit numbers must be passed as a hex string.
sub __bin($$$)
{
    my ( $fh, $bytes, $num ) = @_;

    # $bytes must be a positive integer.
    die "Invalid bytes: $bytes" unless ( 0 < $bytes );

    my $str = ''; # Default invalid string

    my $char = $bytes * 2; # Number of characters in the string.

    # Check if $num is a hex string.
    if ( $num =~ /^0[x|X](.*)/ )
    {
        $str = $1; # strip the '0x'
    }
    # Check if $num is string or numeric decimal integer (32-bit max).
    elsif ( $num =~ /^[0-9]+$/ and $bytes <= 4 )
    {
        $str = sprintf("%0${char}x", $num); # Convert to hex string
    }

    # Check for a hex number with the valid size.
    unless ( $str =~ /^[0-9a-fA-F]{$char}$/ )
    {
        die "Invalid number: $num (size: $bytes)";
    }

    # Print the binary string.
    print $fh pack( "H$char", $str );
}

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

sub __hash($$)
{
    my $bytes = shift;
    my @str   = unpack("C*", shift); # returns an array of ascii values

    # Currently only supporting 1, 2, 3, and 4 byte hashes.
    unless ( 1 <= $bytes and $bytes <= 4 )
    {
        FAIL("Unsupported hash size: $bytes");
    }

    # Add padding to the end of the character array so that the size is
    # divisible by $bytes.
    push @str, 0 until ( 0 == scalar(@str) % $bytes );

    # This hash is a simple "n*s[0] + (n-1)*s[1] + ... + s[n-1]" algorithm,
    # where s[i] is a $bytes size chunk of the input string.

    my ( $sumA, $sumB ) = ( 0, 0 );
    while ( my @chunk = splice @str, 0, $bytes )
    {
        # Combine the chunk array into a single value.
        my $val = 0; for ( @chunk ) { $val <<= 8; $val |= $_; }

        # Apply the simple hash.
        $sumA += $val;
        $sumB += $sumA;
    }

    # Mask off everything except the target number of bytes.
    $sumB &= 0xffffffff >> ((4 - $bytes) * 8);

    return $sumB;
}

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

sub __printRegisters($$)
{
    my ( $fh, $data ) = @_;

    my $num_regs = scalar @{$data};
    FAIL("No registers defined") unless ( 0 < $num_regs );

    # Register list metadata
    __bin($fh, 1, $_) for ( unpack("C*", "REGS") );
    __bin($fh, 3, $num_regs);

    my $reg_ids = {}; # for hash duplicate checking

    for my $r ( @{$data} )
    {
        # Get the hash of the register name and check for duplicates.
        my $id = __hash(3, $r->{name});
        if ( defined $reg_ids->{$id} )
        {
            FAIL("Duplicate register ID hash " . sprintf('0x%08x', $id) .
                 " for $r->{name} and $reg_ids->{$id}");
        }
        else
        {
            $reg_ids->{$id} = $r->{name};
        }

        # Get the attribute flags.
        my $flags = 0x00;
        $flags |= 0x80 if ( $r->{access} =~ /R/ );
        $flags |= 0x40 if ( $r->{access} =~ /W/ );

        # Get the number of address instances.
        my $num_inst = scalar @{$r->{instance}};
        unless ( 0 < $num_inst )
        {
            FAIL("No register instances defined for $r->{name}");
        }

        # Register metadata
        __bin($fh, 3, $id      );
        __bin($fh, 1, $REGISTER_TYPE->{$r->{reg_type}}->{id});
        __bin($fh, 1, $flags   );
        __bin($fh, 1, $num_inst);

        for my $i ( @{$r->{instance}} )
        {
            my $s = $REGISTER_TYPE->{$r->{reg_type}}->{addr_size};

            # Register Instance metadata
            __bin($fh,  1, $i->{reg_inst});
            __bin($fh, $s, $i->{addr}    );
        }
    }
}

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

sub __printExpr($$$);

sub __printExpr($$$)
{
    my ( $fh, $size, $expr ) = @_;

    my ( $t, $e, $v1, $v2 ) = ( $expr->{type}, $expr->{expr},
                                $expr->{value1}, $expr->{value2} );

    if ( "reg" eq $t )
    {
        __bin($fh, 1, 0x01);            # expression type for "reg"
        __bin($fh, 3, __hash(3,$v1));   # register id
        __bin($fh, 1, $v2);             # register instance
    }
    elsif ( "int" eq $t )
    {
        __bin($fh,     1, 0x02);    # expression type for "int"
        __bin($fh, $size, $v1);     # integer value
    }
    elsif ( "and" eq $t )
    {
        __bin($fh, 1, 0x10);                        # expression type for "and"
        __bin($fh, 1, scalar @{$e});                # number of sub-expressions
        __printExpr($fh, $size, $_) for ( @{$e} );  # add each sub-expression
    }
    elsif ( "or" eq $t )
    {
        __bin($fh, 1, 0x11);                        # expression type for "or"
        __bin($fh, 1, scalar @{$e});                # number of sub-expressions
        __printExpr($fh, $size, $_) for ( @{$e} );  # add each sub-expression
    }
    elsif ( "not" eq $t )
    {
        __bin($fh, 1, 0x12);                # expression type for "not"
        __printExpr($fh, $size, $e->[0]);   # add only sub-expression
    }
    elsif ( "lshift" eq $t )
    {
        __bin($fh, 1, 0x13);                # expression type for "lshift"
        __bin($fh, 1, $v1);                 # shift amount
        __printExpr($fh, $size, $e->[0]);   # add only sub-expression
    }
    elsif ( "rshift" eq $t )
    {
        __bin($fh, 1, 0x14);                # expression type for "rshift"
        __bin($fh, 1, $v1);                 # shift amount
        __printExpr($fh, $size, $e->[0]);   # add only sub-expression
    }
}

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

sub __printNodes($$)
{
    my ( $fh, $data ) = @_;

    my $num_nodes = scalar @{$data};
    FAIL("No nodes defined") unless ( 0 < $num_nodes );

    # Isolation Node list metadata
    __bin($fh, 1, $_) for ( unpack("C*", "NODE") );
    __bin($fh, 2, $num_nodes);

    my $node_ids = {}; # for hash duplicate checking

    for my $n ( @{$data} )
    {
        # Get the hash of the node name and check for duplicates.
        my $id = __hash(2, $n->{name});
        if ( defined $node_ids->{$id} )
        {
            FAIL("Duplicate node ID hash " . sprintf('0x%08x', $id) .
                 " for $n->{name} and $node_ids->{$id}");
        }
        else
        {
            $node_ids->{$id} = $n->{name};
        }

        my $num_insts = scalar @{$n->{instance}};
        unless ( 0 < $num_insts )
        {
            FAIL("No nodes instances defined for $n->{name}");
        }

        my $reg_type = $REGISTER_TYPE->{$n->{reg_type}}->{id};
        my $reg_size = $REGISTER_TYPE->{$n->{reg_type}}->{reg_size};

        # Register metadata
        __bin($fh, 2, $id);
        __bin($fh, 1, $reg_type);
        __bin($fh, 1, $num_insts);

        for my $i ( @{$n->{instance}} )
        {
            # Capture groups are optional.
            my $num_cap_regs = (defined $i->{capture_group})
                                    ? scalar @{$i->{capture_group}} : 0;

            # At least one rule is required.
            my $num_rules = scalar @{$i->{rule}};
            unless ( 0 < $num_rules )
            {
                FAIL("No rule for $n->{name} $i->{node_inst}");
            }

            # Child nodes may not exist for this node.
            my $num_bit = (defined $i->{bit}) ? scalar @{$i->{bit}} : 0;

            # Register instance metadata
            __bin($fh, 1, $i->{node_inst});
            __bin($fh, 1, $num_cap_regs  );
            __bin($fh, 1, $num_rules     );
            __bin($fh, 1, $num_bit       );

            if ( 0 < $num_cap_regs )
            {
                for my $cg ( @{$i->{capture_group}} )
                {
                    # Register capture register metadata
                    __bin($fh, 3, __hash(3, $cg->{reg_name}));
                    __bin($fh, 1, $cg->{reg_inst}           );
                }
            }

            for my $r ( @{$i->{rule}} )
            {
                # Register rule metadata
                __bin($fh, 1, $ATTN_TYPE->{$r->{attn_type}});
                __printExpr($fh, $reg_size, $r->{expr});
            }

            if ( 0 < $num_bit )
            {
                for my $b ( @{$i->{bit}} )
                {
                    # Register child node metadata
                    __bin($fh, 1, $b->{pos}                  );
                    __bin($fh, 2, __hash(2, $b->{child_node}));
                    __bin($fh, 1, $b->{node_inst}            );
                }
            }
        }
    }
}

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

sub __printAttnTree($$)
{
    my ( $fh, $data ) = @_;

    my $num_root_nodes = scalar @{$data};
    FAIL("No root nodes defined") unless ( 0 < $num_root_nodes );

    # Root Node list metadata
    __bin($fh, 1, $_) for ( unpack("C*", "ROOT") );
    __bin($fh, 1, $num_root_nodes);

    for my $r ( @{$data} )
    {
        # Root Node metadata
        __bin($fh, 1, $ATTN_TYPE->{$r->{attn_type}});
        __bin($fh, 2, __hash(2, $r->{root_node})   );
        __bin($fh, 1, $r->{node_inst}              );
    }
}

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

sub __printParserData($$$$)
{
    my ( $fh, $model_ec, $sig_list, $reg_list) = @_;

    my $nodes = {};
    my $regs  = {};
    my $sigs  = {};

    for my $s ( @{$sig_list} )
    {
        my $n = sprintf('%04x', __hash(2, $s->{name}));
        my $i = sprintf('%02x', $s->{inst});
        my $b = sprintf('%02x', $s->{bit});

        if ( exists($nodes->{$n}) and $nodes->{$n} ne $s->{name} )
        {
            FAIL("Node hash collision for $n: $nodes->{$n} and $s->{name}");
        }

        $nodes->{$n} = $s->{name};

        if ( exists($sigs->{$n}->{$b}) and $sigs->{$n}->{$b} ne $s->{desc} )
        {
            FAIL("Multiple signatures for $s->{name} bit $s->{bit}:\n" .
                 "  $sigs->{$n}->{$b}\n" .
                 "  $s->{desc}");
        }

        $sigs->{$n}->{$b} = $s->{desc};
    }

    for my $r ( @{$reg_list} )
    {
        my $id = sprintf('%06x', __hash(3, $r->{name}));

        if ( exists($regs->{$id}) and $regs->{$id} ne $r->{name} )
        {
            FAIL("Register hash collision for $id: $regs->{$id} and $r->{name}");
        }

        $regs->{$id} = $r->{name};
    }

    my $data =
    {
        'model_ec'  => $model_ec,
        'node_name' => $nodes,
        'reg_name'  => $regs,
        'signature' => $sigs,
    };

    print $fh to_json( $data, {utf8 => 1, pretty => 1, canonical => 1} );
}

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

sub buildBinary($$)
{
    my ( $dir, $data ) = @_;

    while ( my ($model_ec, $chip) = each %{$data} )
    {
        unless ( defined $chip->{register} )
        {
            FAIL("Chip $model_ec does not contain registers");
        }
        unless ( defined $chip->{node} )
        {
            FAIL("Chip $model_ec does not contain nodes");
        }
        unless ( defined $chip->{attn_tree} )
        {
            FAIL("Chip $model_ec does not contain attn_tree information");
        }
        unless ( defined $chip->{signature} )
        {
            FAIL("Chip $model_ec does not contain signatures");
        }

        # Chip Data Binary files ###############################################

        my $bin_file = "$dir/chip_data_" . lc $model_ec . ".cdb";
        open my $bin_fh, '>', $bin_file or die "Cannot open $bin_file: $!";
        binmode $bin_fh; # writes a binary file

        # Chip Data File metadata
        __bin($bin_fh, 1, $_) for ( unpack("C*", "CHIPDATA") );
        __bin($bin_fh, 4, $SUPPORTED_MODEL_EC->{$model_ec});
        __bin($bin_fh, 1, $FILE_VERSION->{VER_01}         );

        __printRegisters( $bin_fh, $chip->{register}  );
        __printNodes(     $bin_fh, $chip->{node}      );
        __printAttnTree(  $bin_fh, $chip->{attn_tree} );

        close $bin_fh;

        # eBMC PEL parsing JSON ################################################

        my $parser_file = "$dir/chip_parser_" . lc $model_ec . ".json";
        open my $parser_fh, '>', $parser_file
            or die "Cannot open $parser_file: $!";

        __printParserData( $parser_fh, $model_ec, $chip->{signature},
                           $chip->{register} );

        close $parser_fh;
    }
}