#!/usr/bin/perl

#
# Scan Verilog file
#


use strict;
use Getopt::Std;
use vars qw/ %opt /;


#
# Globals
#

my $VERBOSE = undef;
my @EXCLUDE_COMPONENTS;
my @EXCLUDE_MODULES; # = ("or1200_sprs", "or1200_cfgr", "_or1200_fpu", "_or1200_mult_mac");
my @EXCLUDE_WIRES; # = ("clk", "rst");

my @COLORS = (
    "burlywood4",
    "chartreuse4",
    "red4",
    "blue3",
    "cadetblue",
    "darkgreen",
    "blueviolet",
    "blue2",
    "chocolate",
    "cadetblue4",
    "crimson",
    "green4",
    "darkorange4",
    "red2",
    "gold4",
    "firebrick",
    "black",
    "dodgerblue4",
    "brown",
    "darkorchid4",
    "firebrick4"
);


#
# DEBUG
#

sub _dump;
sub _dump($;) {
    my $ref = shift;
    my $level = shift || 0;

    if(ref $ref eq "HASH") {
	print "HASH\n";
	foreach my $key (sort keys %{$ref}) {
	    for(my $i = 0; $i < $level; $i++) {
		print "    ";
	    }
	    print "$key -> ";
	    _dump($ref->{$key}, $level+1);
	}
    }
    elsif(ref $ref eq "ARRAY") {
	print "ARRAY\n";
	foreach my $item (@{$ref}) {
	    for(my $i = 0; $i < $level; $i++) {
		print "    ";
	    }
	    _dump($item, $level + 1);
	}
	return;
    }
    else {
	print "%$ref%\n";
	return;
    }
}



#
# SUBs
#

# check array for string element
sub in_array($@) {
    my $str = shift;
    foreach (@_) {
	return 1 if $_ eq $str;
    }
    return undef;
}


# resolve arithmetics operations
sub resolve_arithmetics($) {
    my $str = shift;

    while($str =~ /(\d+[+-]\d+)/) {
	my $expr = $1;
	my $result = undef;
	eval "\$result = $expr;";
	$str =~ s/(\d+[+-]\d+)/$result/ if defined $result;
    }

    return $str;
}


sub is_keyword($) {
    my $str = shift;
    my @keywords = (
	"reg",
	"assign",
	"always",
	"begin",
	"\$dispaly",
	"end",
	"casez",
	"if",
	"default",
	"case",
	"endcase",
	"or",
	"and",
    );
    my %k = map { $_ => undef } @keywords;
    return ($str =~ /([A-Za-z_][A-Za-z0-9_]*)/ and exists $k{$1}) ? 1 : undef;
}


# resolve define statement
sub resolve_define($$) {
    my $defines_ref = shift;
    my $str = shift;

    if($str =~ /\`define\s+([^\s]+)\s?([^\s]*)/) {				#`
	my($name, $value) = ($1, $2);
	$value =~ s/^\((.*)\)$/$1/;
	while ($value =~ /\`([A-Za-z0-9_]*)/ && exists $defines_ref->{$1}) {	#`
		my $n = $1;
		$value =~ s/\`$n/$defines_ref->{$n}/; #`
	}

	$defines_ref->{$name} = resolve_arithmetics($value);
    }
}

# resolve parameter
sub resolve_parameter($$) {
    my $parameters_ref = shift;
    my $str = shift;

    while ($str =~ /([A-Za-z_][A-Za-z0-9_]*)/) {
	my $name = $1;
	last unless exists $parameters_ref->{$name};
	$str =~ s/$name/$parameters_ref->{$name}/;
	$str = resolve_arithmetics($str);
    }

    return $str;
}


sub verilog_load($;$) {
    my $filename = shift;
    my $defines_ref = shift || {};
    my $if_hide = undef;
    my $if_cnt = 0;
    my $n = 0;

    print STDERR "Loading: $filename\n" if $VERBOSE;
    die "file not found: $filename\n" unless -f $filename;

    my($basedir) = ($filename =~ /(.*)\/[^\/]+$/);

    my $FILE;
    open $FILE, "<$filename" || die "Can\'t open $filename: $!\n";

    my $result = "";
    while(my $str = <$FILE>) {
	$n++;
	$str =~ s/\n//;

	# remove spaces
	$str =~ s/^\s+//g;
	$str =~ s/\s+/ /g;

	# remove singleline comments: //
	$str = (split /\/\//, $str)[0];

	# skip empty strings
	next if $str eq "";

	#resolve if/endif contitional
	if ($str =~ /^`if(n?)def\s+([A-Za-z_][A-Za-z0-9_]*)/) {		#`
	    $if_cnt++;
	    if ($1 eq "") {
		$if_hide = exists $defines_ref->{$2} ? undef : 1;
	    }
	    else {
		$if_hide = exists $defines_ref->{$2} ? 1 : undef;
	    }
	}
	if ($str =~ /^`else/) {				#`
	    die "else without if: $n: $str\n" if $if_cnt == 0;
	    $if_hide = $if_hide ? undef : 1;
	}
	if ($str =~ /^`endif/) {			#`
	    $if_cnt--;
	    die "endif without if: $n :$str\n" if $if_cnt < 0;
	    $if_hide = undef if $if_cnt == 0;
	}
	next if $if_hide;

	# resolve define definitions
	if ($str =~ /^`define\s+/) {			#`
	    resolve_define($defines_ref, $str);
	    next;
	}

	# resolve include
	if ($str =~ /^`include\s+\"(.*)\"/) {		#`
	    $result .= verilog_load("$basedir/$1", $defines_ref);
	    next;
	}

	# skip other preprocessor directives
	next if $str =~ /^`/;				#`

	# resolve defines in statement
	while ($str =~ /`([A-Za-z0-9_]+)/) {		#`
	    my $name = $1;
	    last unless exists $defines_ref->{$name};
	    $str =~ s/`$name/$defines_ref->{$name}/;	# `
	    $str = resolve_arithmetics($str);
	}

	$result .= $str." ";
    }

    close $FILE;

    # remove multiline comments /* ... */
    $result =~ s/\/\*.*?\*\///sg;


    # split strings by ';' and 'endmodule'
    $result =~ s/;/;\n/g;
    $result =~ s/([\s;]|)endmodule([\s;]|)/\nendmodule\n/g;
    $result =~ s/\n\n/\n/g;

    # remove unnecessary spaces from result
    $result =~ s/^\s+//gm;
    $result =~ s/\s+$//gm;
    #$result =~ s/\s{2;}//g;
    #$result =~ s/\s+([;\[\]])\s+/$1/g;

    return $result;
}


sub verilog_parse($) {
    my $verilog_str = shift;
    my %modules;
    my $module_ref;
    my %wires_used;

    foreach my $str (split /\n/, $verilog_str) {
	if($str =~ /^module\s+([A-Za-z_][A-Za-z0-9_]*)\s*\((.*)\)\s*;/) {
	    die "module in module!!!\n" if defined $module_ref;
	    my $name = $1;
	    my $pins = $2;

	    $pins =~ s/\s//g;
	    %wires_used = ();
	    
	    $module_ref = {
		'name' => $name,
		'wires' => {},
		'parameters' => {},
		'components' => {},
	    };
	}
	elsif($str =~ /^endmodule;?$/) {
	    die "endmodule before module!!!\n" unless defined $module_ref;

	    # remove parameters
	    map { delete $wires_used{$_} if exists $wires_used{$_} } keys %{$module_ref->{'parameters'}};
	    
	    # mark used wires
	    map { $module_ref->{'wires'}->{$_}->{'used'} = 1 if exists $module_ref->{'wires'}->{$_} } keys %wires_used;

	    $modules{$module_ref->{'name'}} = $module_ref;
	    $module_ref = undef;
	}
	elsif($str =~ /^parameter\s+([A-Za-z0-9_]+)\s+=\s+(.*);$/) {
	    die "paramener before module!!!\n" unless defined $module_ref;
	    $module_ref->{'parameters'}->{$1} = $2;
	}
	elsif($str =~ /^(input|output|inout|wire)\s+(.*)/) {
	    die "$1 before module!!!\n" unless defined $module_ref;
	    my($dir, $sigs, $width, $width_num) = ($1, $2, "", 1);
	    if($sigs =~ /^\[([^:]+):([^:]+)\]\s+(.*)/) {
		my($width_end, $width_start) = ($1, $2);
		$sigs = $3;

		$width_start = resolve_parameter($module_ref->{'parameters'}, $width_start);
		$width_end = resolve_parameter($module_ref->{'parameters'}, $width_end);

		$width = "$width_end:$width_start";
		$width_num = $width_end - $width_start + 1;
	    }
	    
	    
	    foreach my $sig (split /,/, $sigs) {
		$sig =~ s/^\s*([A-Za-z_][A-Za-z0-9_]*).*/$1/;

#		die "invalid signal $sig { $module_ref->{'wires'}->{$sig}->{'type'} }\n" unless 
#		    exists $module_ref->{'wires'}->{$sig};

		if (exists $module_ref->{'wires'}->{$sig} and $module_ref->{'wires'}->{$sig}->{'dir'} ne "wire") {
		    next;
		}

		$module_ref->{'wires'}->{$sig} = {
		    'name' => $sig,
		    'dir' => $dir,
		    'width' => $width,
		    'width_num' => $width_num,
		    'used' =>  undef
		};
	    }
	}
	elsif($str =~ /^([A-Za-z_][A-Za-z0-9_]*)\s+([A-Za-z_][A-Za-z0-9_]*)\s*\((.*)\);/ or 
		$str =~ /([A-Za-z_][A-Za-z0-9_]*)\s*#\(.*\)\s*([A-Za-z_][A-Za-z0-9_]*)\s*\((.*)\);/) {
	    die "component before module: $str\n" unless defined $module_ref;
	    my($module, $name, $signals) = ($1, $2, $3);
	    my $is_component = 1;

	    my $component_ref = {
		'name' => $name,
		'module' => $module,
		'signals' => {},
	    };

	    foreach my $signal_str (split /,/, $signals) {
		unless($signal_str =~ /\.([A-Za-z_][A-Za-z0-9_]*).*\(([A-Za-z_][A-Za-z0-9_]*).*\)/) {
		    $is_component = undef;
		    last;
		}
		$component_ref->{'signals'}->{$2} = $1;
	    }
	    
	    if ($is_component) {
		$module_ref->{'components'}->{$name} = $component_ref;
	    }
	    else {
		print STDERR "$str\n" if $VERBOSE;
		while($str =~ /([A-Za-z_][A-Za-z0-9_]*)/) {
		    $wires_used{$1} = undef;
		    $str =~ s/$1/%/;
		}
	    }
	}
	else {
	    print STDERR "$str\n" if $VERBOSE;
	    while($str =~ /([A-Za-z_][A-Za-z0-9_]*)/) {
		$wires_used{$1} = undef;
		$str =~ s/$1/%/;
	    }
	}
    }

    return %modules;
}


sub load_dir($);
sub load_dir($) {
    my $dirname = shift;
    my %modules;

    opendir DIR, $dirname || die "Can't open $dirname: $!\n";
    my @files = readdir DIR;
    close DIR;

    foreach my $filename (@files) {
	next if $filename eq "." or $filename eq "..";

	$filename = "$dirname/$filename";
	if(-d $filename) {
	    %modules = (%modules, load_dir($filename));
	}
	elsif(-f $filename and $filename =~ /\.v$/) {
	    print STDERR "Loading: $filename\n" if $VERBOSE;

	    my $verilog_str = verilog_load($filename);
	    my %parsed_modules = verilog_parse($verilog_str);

	    # append
	    foreach my $module_name (keys %parsed_modules) {
		die "Two modules in different files with a same name $module_name\n" if
		    exists $modules{$module_name};
		$modules{$module_name} = $parsed_modules{$module_name};
	    }
	}
    }

    return %modules;
}


# FixMe: возвращаем модули, а не компоненты!!!!
sub get_components($$);
sub get_components($$) {
    my $modules_ref = shift;
    my $component_ref = shift;
    my %components;

    my $module_name = $component_ref->{'module'};
    my $module_ref = $modules_ref->{$module_name};

    return () if in_array($component_ref->{'name'}, @EXCLUDE_COMPONENTS) or
	in_array($module_name, @EXCLUDE_MODULES);

    $components{$component_ref->{'name'}} = undef;

    # trace component components
    foreach my $component_name (keys %{$module_ref->{'components'}}) {
	%components = (%components, map { $_ => undef } get_components($modules_ref, $module_ref->{'components'}->{$component_name}));
    }

    return keys %components;
}


sub component_wire_trace($$$);
sub component_wire_trace($$$) {
    my $modules_ref = shift;
    my $a_component_ref = shift;
    my $a_wire_ref = shift;
    my @trace;

    my $a_component_name = $a_component_ref->{'name'};
    my $a_module_name = $a_component_ref->{'module'};
    my $a_module_ref = $modules_ref->{$a_module_name};
    my $a_wire_name = $a_wire_ref->{'name'};

    foreach my $b_component_name (keys %{$a_module_ref->{'components'}}) {
	my $b_component_ref = $a_module_ref->{'components'}->{$b_component_name};
	if (exists $b_component_ref->{'signals'}->{$a_wire_name}) {
		my $b_module_name = $b_component_ref->{'module'};
		my $b_wire_name = $b_component_ref->{'signals'}->{$a_wire_name};

		my $b_module_ref = $modules_ref->{$b_module_name};
		my $b_wire_ref = $b_module_ref->{'wires'}->{$b_wire_name};

		push @trace, { 
		    'a_module' => $a_module_ref,
		    'a_component' => $a_component_ref,
		    'a_wire' => $a_wire_ref,
		    'b_module' => $b_module_ref,
		    'b_component' => $b_component_ref,
		    'b_wire' => $b_wire_ref
		};

		@trace = (@trace, component_wire_trace($modules_ref, $b_component_ref, $b_wire_ref));
	}
    }

    return @trace;
}


sub component_trace($$);
sub component_trace($$) {
    my $modules_ref = shift;
    my $component_ref = shift;
    my @trace;

    my $module_name = $component_ref->{'module'};
    my $module_ref = $modules_ref->{$module_name};

    # trace component wires
    foreach my $wire_name (keys %{$module_ref->{'wires'}}) {
	my $wire_ref = $module_ref->{'wires'}->{$wire_name};

	@trace = (@trace, component_wire_trace($modules_ref, $component_ref, $wire_ref));
    }

    # trace component components
    foreach my $component_name (keys %{$module_ref->{'components'}}) {
	my $component_ref = $module_ref->{'components'}->{$component_name};

	@trace = (@trace, component_trace($modules_ref, $component_ref));
    }

    return @trace;
}

sub hop_key($) {
    my $hop_ref = shift;
    my $a = "$hop_ref->{'a_module'}->{'name'}.$hop_ref->{'a_component'}->{'name'}.$hop_ref->{'a_wire'}->{'name'}";
    my $b = "$hop_ref->{'b_module'}->{'name'}.$hop_ref->{'b_component'}->{'name'}.$hop_ref->{'b_wire'}->{'name'}";
    return join(":", sort ($a, $b));
}

sub trace_group(@) {
    my %trace = map { hop_key($_) => $_ } @_;

    # continious chains
    my $cont;
    do {
	my $cont = undef;
	foreach my $a_hop_key (keys %trace) {
	    my $a_hop_ref = $trace{$a_hop_key};

	    foreach my $b_hop_key (keys %trace) {
		my $b_hop_ref = $trace{$b_hop_key};

		next if $b_hop_ref == $a_hop_ref;

		my($a_module_ref, $a_component_ref, $a_wire_ref, $b_module_ref, $b_component_ref, $b_wire_ref);
		if($a_hop_ref->{'b_module'} == $b_hop_ref->{'a_module'} and $a_hop_ref->{'b_wire'} eq $b_hop_ref->{'a_wire'}) {
		    $a_module_ref = $a_hop_ref->{'a_module'};
		    $a_component_ref = $a_hop_ref->{'a_component'};
		    $a_wire_ref = $a_hop_ref->{'a_wire'};
		    $b_module_ref = $b_hop_ref->{'b_module'};
		    $b_component_ref = $b_hop_ref->{'b_component'};
		    $b_wire_ref = $b_hop_ref->{'b_wire'};
		}
		elsif($a_hop_ref->{'a_module'} == $b_hop_ref->{'a_module'} and $a_hop_ref->{'a_wire'} eq $b_hop_ref->{'a_wire'}) {
		    $a_module_ref = $a_hop_ref->{'b_module'};
		    $a_component_ref = $a_hop_ref->{'b_component'};
		    $a_wire_ref = $a_hop_ref->{'b_wire'};
		    $b_module_ref = $b_hop_ref->{'b_module'};
		    $b_component_ref = $b_hop_ref->{'b_component'};
		    $b_wire_ref = $b_hop_ref->{'b_wire'};
		}
		else {
		    next;
		}

		# construct new trace hop
		my $new_hop_ref = {
		    'a_module' => $a_module_ref,
		    'a_component' => $a_component_ref,
		    'a_wire' => $a_wire_ref,
		    'b_module' => $b_module_ref,
		    'b_component' => $b_component_ref,
		    'b_wire' => $b_wire_ref
		};
		my $new_hop_key = hop_key($new_hop_ref);

		next if exists $trace{$new_hop_key};

		$trace{$new_hop_key} = $new_hop_ref;
		$cont = 1;
	    }
	}
    } while($cont);

    # filter
    foreach my $hop_key (keys %trace) {
	my $hop_ref = $trace{$hop_key};

	if(
	    # components
	    in_array($hop_ref->{'a_component'}->{'name'}, @EXCLUDE_COMPONENTS) or
	    in_array($hop_ref->{'b_component'}->{'name'}, @EXCLUDE_COMPONENTS) or
	    # modules
	    in_array($hop_ref->{'a_module'}->{'name'}, @EXCLUDE_MODULES) or
	    in_array($hop_ref->{'b_module'}->{'name'}, @EXCLUDE_MODULES) or
	    # wires
	    in_array($hop_ref->{'a_wire'}->{'name'}, @EXCLUDE_WIRES) or
	    in_array($hop_ref->{'b_wire'}->{'name'}, @EXCLUDE_WIRES)
	)
	{
	    print STDERR "Filter hop: $hop_key\n" if $VERBOSE;
	    delete $trace{$hop_key};
	}
    }

    # remove unused
    foreach my $hop_key (keys %trace) {
	my $hop_ref = $trace{$hop_key};
	
	if(not $hop_ref->{'a_wire'}->{'used'} or not $hop_ref->{'b_wire'}->{'used'}) {
	    print STDERR "Remove unused hop: $hop_key (a_wire: ".
		($hop_ref->{'a_wire'}->{'used'} ? "yes" : "no").", b_wire=".
		($hop_ref->{'b_wire'}->{'used'} ? "yes" : "no").")\n" if $VERBOSE;
	    delete $trace{$hop_key};
	}
    }

    return map { $trace{$_} } keys %trace;
}

sub module_to_graphvis($$$) {
    my $modules_ref = shift;
    my $module_name = shift;
    my $draw_color = shift;

    my $module_ref = $modules_ref->{$module_name};

    # create top component
    my %wires = map { $_ => $_ } keys %{$module_ref->{'wires'}};
    my $component_ref = {
	'name' => $module_ref->{'name'},
	'module' => $module_ref->{'name'},
	'signals' => \%wires
    };

    print <<EOF;
digraph finite_state_machine {
    rankdir=LR;
    node [shape = box];
EOF

    # get all comonents of module
    my $color_index = 0;
    my %color_component;
    my @components = get_components($modules_ref, $component_ref);
    foreach my $component_name (@components) {
	$color_component{$component_name} = $COLORS[$color_index++];
	if($draw_color) {
	    print "    \"$component_name\" [style=filled color=".$color_component{$component_name}."];\n"
	}
	else {
	    print "    \"$component_name\";\n"
	}
    }

    # get module wires trace
    my @trace = component_trace($modules_ref, $component_ref);

    @trace = trace_group(@trace);

    # reorder (indexing) trace data
    my %graph;
    foreach my $hop_ref (@trace) {
	my $dir = $hop_ref->{'b_wire'}->{'dir'} eq "input" ? "->" : ($hop_ref->{'b_wire'}->{'dir'} eq "output" ? "<-" : "??");
	die "invalid dir: $hop_ref->{'a_module'}->{'name'} $hop_ref->{'a_component'}->{'name'}($hop_ref->{'a_wire'}->{'name'} ".
	    "[$hop_ref->{'a_wire'}->{'dir'}]) $dir $hop_ref->{'b_module'}->{'name'} $hop_ref->{'b_component'}->{'name'}($hop_ref->{'b_wire'}->{'name'} ".
	    "[$hop_ref->{'b_wire'}->{'dir'}])\n" if $dir eq "??";

	my ($from, $to, $signal, $width_num) = ($dir eq "->") ? (
		"$hop_ref->{'a_component'}->{'name'}", 
		"$hop_ref->{'b_component'}->{'name'}", 
		"$hop_ref->{'a_wire'}->{'name'}".($hop_ref->{'a_wire'}->{'width'} ne "" ? "[$hop_ref->{'a_wire'}->{'width'}]" : ""),
		$hop_ref->{'a_wire'}->{'width_num'}
	    ) : (
		"$hop_ref->{'b_component'}->{'name'}",
		"$hop_ref->{'a_component'}->{'name'}",
		"$hop_ref->{'b_wire'}->{'name'}".($hop_ref->{'b_wire'}->{'width'} ne "" ? "[$hop_ref->{'b_wire'}->{'width'}]" : ""),
		$hop_ref->{'a_wire'}->{'width_num'}
	    );

	#next if $width_num <= 1;

	my $key = ($width_num > 1) ? "$from.$to.$signal.$width_num" : "$from.$to";
	if(exists $graph{$key}) {
	    $graph{$key} .= ", $signal";
	}
	else {
	    $graph{$key} .= "$signal";
	}
    }

    foreach (sort keys %graph) {
	my $signal = $graph{$_};
	my($from, $to, undef, $width_num) = split /\./, $_;
	my $penwidth = int($width_num * 0.15) + 1;
	if ($draw_color) {
	    print "    ".$from.'->'.$to." [label=\"$signal\"".
		($width_num ? " penwidth=\"$penwidth\"" : "").
		" color=".$color_component{$from}."]\n";
	}
	else {
	    print "    ".$from.'->'.$to." [label=\"$signal\"".
		($width_num ? " penwidth=\"$penwidth\"" : "")."]\n";
	}
    }

    print <<EOF;
}
EOF
}


 # show usage message
sub usage() {
    print <<EOF;
usage: verilog_to_graphviz.pl -t <top module> 
                              [-v] [-b]
                              [-c <component>[,<component>...]
                              [-m <module>[<,module>...]]
                              [-w <wire>[,<wire>...]
                              <verilog project directory>
       verilog_to_graphviz.pl -h

EOF
    exit(255);
}

#
# Entry point
#

getopts("t:bc:m:w:vh", \%opt) or usage();
usage() if defined $opt{'h'};
usage() unless defined $opt{'t'};

$VERBOSE = defined $opt{'v'};
@EXCLUDE_COMPONENTS = split /,/, $opt{'c'};
@EXCLUDE_MODULES = split /,/, $opt{'m'};
@EXCLUDE_WIRES = split /,/, $opt{'w'};
my $dirname = shift;

my %modules = load_dir($dirname);
module_to_graphvis(\%modules, $opt{'t'}, $opt{'b'} ? undef : 1);