#!/usr/bin/perl -w

use strict;
use Parrot::Opcode;
use Getopt::Std;
use Symbol;


####################
# Arguments.

sub usage {
    print STDERR "Usage: $0 -d <function | switch> [<file> ...]\n";
    exit 1;
}

my %opts = (d => "function");
getopts("d:", \%opts) or usage;

if ($opts{d} ne "function" && $opts{d} ne "switch") {
    print STDERR "Supported dispatch modes: function, switch.\n";
    exit 1;
}


####################
# Opcodes.

my $opcode_fingerprint = Parrot::Opcode::fingerprint();
my %opcodes            = Parrot::Opcode::read_ops();
my @opcodes;

for my $name (keys %opcodes) {
    my $op = $opcodes{$name};
    push @opcodes, $op;
    $op->{NAME} = $name;
}

@opcodes = sort { $a->{CODE} <=> $b->{CODE} } @opcodes;

my %files;
for my $f (@ARGV) {
    $files{$f} = [ read_ops($f) ];
}


####################
# quoted() is used to simplify generation.  The leading regex /\s*#/ is
# stripped from text, to allow here-docs to be set off from the surrounding
# Perl code.  Lines beginning with /\s*\#\*/ are printed once for every
# opcode.  Text surrounded in curly braces, like {THIS}, is replaced with
# the value of the appropriate field in the opcode definition.

sub quoted {
    my $s = "";
    for (split /\n/, $_[0]) {
	if (s/^\s*\#\*//) {
	    for my $op (@opcodes) {
		my $t = $_; $t =~ s/{(\w+)}/$op->{$1}/ge;
		$s .= "$t\n";
	    }
	}
	elsif (s/^\s*\# ?//) {
	    $s .= "$_\n";
	}
    }
    $s;
}


####################
# op.h

open OP_H, "> include/parrot/op.h"
  or die "include/parrot/op.h: $!\n";
print OP_H quoted(<<END)
# /*
#  * op.h
#  * Opcode header.
#  * This file is autogenerated by generate.pl -- DO NOT EDIT.
#  */
#
# #if !defined(PARROT_OP_H_GUARD)
# #define PARROT_OP_H_GUARD
#
# typedef IV OP;
#
# #define DEFAULT_OPCODE_TABLE NULL
#
END
  ;

if ($opts{d} eq "function") {
    print OP_H quoted(<<END)
#*#define {NAME} Parrot_op_{NAME}
#
#*opcode_t *{NAME}(opcode_t *, struct Parrot_Interp *);
END
  ;
}

print OP_H quoted(<<END)
#
# #endif
END
  ;


####################
# interp_guts.h

open INTERP, "> include/parrot/interp_guts.h"
  or die "include/parrot/interp_guts.h: $!\n";
print INTERP quoted(<<END)
# /*
#  * interp_guts.h
#  *
#  * This file is autogenerated by generate.pl -- DO NOT EDIT.
#  */
#
# #define BUILD_TABLE(x) do { \\
END
  ;

for my $op (@opcodes) {
    if ($opts{d} eq "function") {
	print INTERP "\tx[$op->{CODE}] = (void*)$op->{NAME}; \\\n";
    } else {
	print INTERP "\tx[$op->{CODE}] = NULL; \\\n";
    }
}

print INTERP quoted(<<END)
# } while (0);
#
# #define BUILD_NAME_TABLE(x) do { \\
#*	x[{CODE}] = \"{NAME}\"; \\
# } while (0);
#
# #define BUILD_ARG_TABLE(x) do { \\
#*	x[{CODE}] = {ARGS}; \\
# } while(0);
#
END
  ;

if ($opts{d} eq "function") {
    print INTERP quoted(<<END)
      # #define DO_OP(code, temp, func, interp) do { \\
      #     temp = (void *)interp->opcode_funcs; \\
      #     func = (opcode_t* (*)())temp[*code]; \\
      #     code = (func)(code, interp); \\
      # } while(0);
END
  ;
} elsif ($opts{d} eq "switch") {
    print INTERP "#define DO_OP(cur_opcode, temp, func, interp) do { \\\n";
    print INTERP "  switch (*cur_opcode) { \\\n";

    for my $op (@opcodes) {
	if (defined $op->{IMPL_BODY}) {
	    my $body = $op->{IMPL_BODY};
	    $body =~ s/RETVAL/return_offset/g;
	    $body =~ s/RETURN\(0\);/;/g;
	    $body =~ s/RETURN\((.*)\)/cur_opcode = cur_opcode + $1; break/g;

	    print INTERP "  case $op->{CODE}: { \\\n";
	    for (split /\n/, $body) {
		print INTERP "$_ \\\n";
	    }
	    print INTERP "    cur_opcode += $op->{IMPL_RETURN_ADDR}; } \\\n";
	    print INTERP "    break; \\\n";
	}
    }

    print INTERP "  default: \\\n";
    print INTERP "    exit(1); /* XXX: Better error trapping */ \\\n";
    print INTERP "  } } while(0)\n";
}

print INTERP quoted(<<END)
#
# #define OPCODE_FINGERPRINT "$opcode_fingerprint"
END
  ;

close INTERP;


####################
# Generate opcode files.

for my $f (@ARGV) {
    my $output = $f;
    $output =~ s/(\.ops)?$/.c/;

    open OUTPUT, "> $output" or die "$output: $!\n";

    print OUTPUT quoted(<<END)
      # /*
      #  * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
      #  * This file is automatically generated from $f.
      #  * Edit it instead.
      #  */
      #
      # #include "parrot/parrot.h"
      # #include <math.h>
      #
END
  ;

    if ($opts{d} ne "function") {
	close OUTPUT;
	next;
    }

    for my $name (@{$files{$f}}) {
	my $op = $opcodes{$name};

	my $body = $op->{IMPL_BODY};
	$body =~ s/RETVAL/return_offset/g;
	$body =~ s/RETURN\(0\);/return 0;/g;
	$body =~ s/RETURN\((.*)\)/return cur_opcode + $1/g;

	print OUTPUT "#line $op->{IMPL_LINE} \"$op->{IMPL_FILE}\"\n";
	print OUTPUT ("opcode_t *$op->{FUNC}(".
		      "opcode_t cur_opcode[], ".
		      "struct Parrot_Interp *interpreter".
		      ") {\n");
	print OUTPUT $body;
	print OUTPUT "  return cur_opcode + $op->{IMPL_RETURN_ADDR};\n}\n\n";
    }

    close OUTPUT;
}



####################
# Read opcode function definitions.
#
# Opcode functions are in the format:
#
#  AUTO_OP opname {
#
#   ... body of function ...
#
#  }
#
# Where the closing brace is on its own line. Alternately, for opcode
# functions that manage their own return values:
#
# MANUAL_OP opname {
#
#    ... body of function ...
#
#    RETVAL = x;
#
# }
#
# There may be more than one RETVAL
#
# The functions have the magic variables Pnnn for parameters 1 through
# X. (Parameter 0 is the opcode number) Types for each, and the size
# of the return offset, are taken from the opcode_table file

sub read_ops {
    my($file) = @_;

    open INPUT, $file or die "$file: $!\n";

    my @ops;
    my($name, $body, $footer, $offset, @param_sub);
    while (<INPUT>) {
	if (/^AUTO_OP/) {
	    $body = "";
	    ($name, $footer, $offset) = auto_code($_);
	}

	if (/^MANUAL_OP/) {
	    ($name, $footer, $offset) = manual_code($_);
	    $body = "  IV return_offset = $offset;\n";
	}

	if (/^(AUTO|MANUAL)_OP/) {
	    push @ops, $name;

	    if (defined $opcodes{$name}{IMPL_FILE}) {
		print STDERR "Warning: $name implemented multiple times:\n";
		print STDERR "  $opcodes{$name}{IMPL_FILE}, ",
		  "line $opcodes{$name}{IMPL_LINE}\n";
		print STDERR "  $file, line $.\n";
	    }

	    $opcodes{$name}{IMPL_FILE} = $file;
	    $opcodes{$name}{IMPL_LINE} = $.;

	    my $count = 1;
	    @param_sub = ("",
			  map {if ($_ eq "n") {
			      my $temp = '*(NV *)&cur_opcode['.$count.']';
			      $count += 2;
			      $temp;
			  } else {
			      "cur_opcode[" . $count++ . "]"
			  }
			   } @{$opcodes{$name}{TYPES}});
	    next;
	}

	s/\bP(\d+)\b/$param_sub[$1]/g;

	if (/^\}/) {
	    $opcodes{$name}{IMPL_BODY}        = $body;
	    $opcodes{$name}{IMPL_RETURN_ADDR} = $footer;

	    $name      = undef;
	    $body      = undef;
	    $footer    = undef;
	    @param_sub = ();
	}

	if (defined $body) {
	    $body .= $_;
	}
    }

    close INPUT;

    return @ops;
}

my %psize;
BEGIN {
    %psize = (i => 1,
	      n => 2,
	      I => 1,
	      N => 1,
	      D => 1,
	      S => 1,
	      s => 1,
	     );
}

sub auto_code {
    my($line) = @_;
    my($name) = $line =~ /^AUTO_OP\s+(\w+)/;
    die "$name: unknown opcode\n" unless $opcodes{$name};

    my $psize = 0;
    foreach (@{$opcodes{$name}{TYPES}}) {
	$psize+=$psize{$_};
    }
    my $return_offset = $psize + 1;

    return($name, $return_offset, $return_offset);
}

sub manual_code {
    my($line) = @_;
    my($name) = $line =~ /^MANUAL_OP\s+(\w+)/;
    die "$name: unknown opcode\n" unless $opcodes{$name};

    my $psize = 0;
    foreach (@{$opcodes{$name}{TYPES}}) {
	$psize+=$psize{$_};
    }
    my $return_offset = $psize + 1;

    return($name, "return_offset", $return_offset);
}