#! /opt/local/bin/perl -w
$target = \&emulator_output;
$verbose = 0;
$BEAM_FORMAT_NUMBER = undef;
$unique_label = 1;
$hot = 1;
$num_file_opcodes = 0;

# This is shift counts and mask for the packer.
$WHOLE_WORD = 0xFFFFFFFF;
$pack_instr[2] = ['6', 'i'];
$pack_instr[3] = ['0', '0', 'i'];
$pack_shift[2] = [0, 16];
$pack_shift[3] = [0, 10, 20];
$pack_mask[2]  = [0xFFC, $WHOLE_WORD];
$pack_mask[3]  = [0xFFC, 0xFFC, 0xFFC];

#
# The following will be updated when instructions transformations are compiled.
#
$te_max_window = 0;		# Max window size ever needed.
$te_max_vars = 0;		# Max number of variables ever needed.

#
# Defines the argument types and their loaded size assuming no packing.
#
%arg_size = ('r' => 0,		# x(0) - x register zero
	     'x' => 1,		# x(N), N > 0 - x register
	     'y' => 1,		# y(N) - y register
	     'i' => 1,		# tagged integer
	     'a' => 1,		# tagged atom
	     'n' => 0,		# NIL (implicit)
	     'c' => 1,		# tagged constant (integer, atom, nil)
	     's' => 1,		# tagged source; any of the above
	     'd' => 1,		# tagged destination register (r, x, y)
	     'f' => 1,		# failure label
	     'p' => 1,		# any pointer
	     'j' => 1,		# either 'f' or 'p'
	     'e' => 1,		# pointer to export entry
	     'L' => 0,		# label
	     'I' => 1,		# untagged integer
	     'b' => 1,		# pointer to bif
	     'A' => 1,		# arity value
	     'N' => 1,		# big number (arity and sign)
	     'u' => 1,		# a part of a big number
	     'P' => 1,		# byte offset into tuple
	     );

# Subset of types -- significant for determing which specific instruction to use.

$significant_types = "rxyniafp";

#
# Generate bits for each signifcant type.
#
{
    my($bit) = 1;
    my(%bit);

    foreach (split('', $significant_types)) {
	push(@tag_type, $_);
	$type_bit{$_} = $bit;
	$bit{$_} = $bit;
	$bit *= 2;
    }

    # Composed types.
    $type_bit{'d'} = $type_bit{'x'} | $type_bit{'y'} | $type_bit{'r'};
    $type_bit{'c'} = $type_bit{'i'} | $type_bit{'a'} | $type_bit{'n'};
    $type_bit{'s'} = $type_bit{'d'} | $type_bit{'c'};
    $type_bit{'j'} = $type_bit{'f'} | $type_bit{'p'};

    # Aliases.
    $type_bit{'I'} = $type_bit{'i'};
    $type_bit{'A'} = $type_bit{'i'};
    $type_bit{'L'} = $type_bit{'i'};
    $type_bit{'b'} = $type_bit{'i'};
    $type_bit{'N'} = $type_bit{'i'};
    $type_bit{'u'} = $type_bit{'i'};
    $type_bit{'e'} = $type_bit{'i'};
    $type_bit{'P'} = $type_bit{'i'};
}

#
# Parse command line options.
#

while (@ARGV && $ARGV[0] =~ /^-(.*)/) {
    $_ = $1;
    shift;
    ($target = \&emulator_output), next if /^emulator/;
    ($target = \&compiler_output), next if /^compiler/;
    ($verbose = 1), next if /^v/;
    die "$0: Bad option: -$_\n";
}

#
# Parse the file input file.
#

while (<>) {
    my($op_num);
    next if /^\s*$/;
    next if /^\#/;
    chomp;
    
    #
    # Handle assignments.
    #
    if (/^([\w_][\w\d_]+)=(.*)/) {
	my($name) = $1;
	$$name = $2;
	next;
    }

    #
    # Handle %hot/%cold.
    # 
    if (/^\%hot/) {
	$hot = 1;
	next;
    } elsif (/^\%cold/) {
	$hot = 0;
	next;
    }
    
    #
    # Handle macro definitions.
    #
    if (/^\%macro:(.*)/) {
	my($op, $macro, @flags) = split(' ', $1);
	defined($macro) and $macro =~ /^-/ and
	    &error("A macro must not start with a hyphen");
	foreach (@flags) {
	    /^-/ or &error("Flags for macros should start with a hyphen");
	}
	$macro{$op} = $macro;
	$macro_flags{$op} = join('', @flags);
	next;
    }

    #
    # Handle transformations.
    #
    if (/=>/) {
	&parse_transformation($_);
	next;
    }

    #
    # Parse off the number of the operation.
    #
    $op_num = undef;
    if (s/^(\d+):\s*//) {
	$op_num = $1;
	$op_num != 0 or &error("Opcode 0 invalid");
	&error("Opcode $op_num in use (defined at line $op[$op_num]->[0])")
	    if defined $op_num && $op[$op_num];
    }

    #
    # Parse: Name/Arity  (generic instruction)
    #
    if (m@^(\w+)/(\d)\s*$@) {
	my($name) = $1;
	my($arity) = $2;
	$name =~ /^[a-z]/ or &error("Opname must start with a lowercase letter");
	defined $gen_arity{$name} and $gen_arity{$name} != $arity and
	    &error("Opname $name already defined with arity $gen_arity{$name}");
	defined $unnumbered{$name,$arity} and
	    &error("Opname $name already defined with arity $gen_arity{$name}");

	if (defined $op_num) {	# Numbered generic operation
	    $gen_opname[$op_num] = $name;
	    $gen_arity[$op_num] = $arity;
	    $gen_opnum{$name,$arity} = $op_num;
	    $gen_arity{$name} = $arity;
	    $gen_to_spec{"$name/$arity"} = 0;
	    $num_specific{"$name/$arity"} = 0;
	    $min_window{"$name/$arity"} = 255;
	} else {		# Unnumbered generic operation.
	    push(@unnumbered_generic, [$name, $arity]);
	    $unnumbered{$name,$arity} = 1;
	}
	next;
    }

    #
    # Parse specific instructions (only present in emulator/loader):
    #    Name Arg1 Arg2...
    #
    my($name, @args) = split;
    &syntax_check($name, @args);
    my $arity = @args;
    push(@{$specific_op{"$name/$arity"}}, [$name, $hot, @args]);
    if (defined $op_num) {
	#
	# Create a numbered generic instruction too.
	#
	$name =~ /^[a-z]/ or &error("Opname must start with a lowercase letter");
	defined $gen_arity{$name} and $gen_arity{$name} != $arity and
	    &error("Opname $name already defined with arity $gen_arity{$name}");

	$gen_opname[$op_num] = $name;
	$gen_arity[$op_num] = $arity;
	$gen_opnum{$name,$arity} = $op_num;
	$gen_arity{$name} = $arity;
	$gen_to_spec{"$name/$arity"} = 0;
	$num_specific{"$name/$arity"} = 0;
	$min_window{"$name/$arity"} = 255;
    } elsif (!defined($gen_arity{$name}) && !defined($unnumbered{$name,$arity})) {
	#
	# Create an unumbered generic instruction too.
	#
	push(@unnumbered_generic, [$name, $arity]);
	$unnumbered{$name,$arity} = 1;
    }
}

$num_file_opcodes = @gen_opname;

#
# Number all generic operations without numbers.
#
foreach $ref (@unnumbered_generic) {
    my($name, $arity) = @$ref;
    my $op_num = @gen_opname;
    push(@gen_opname, $name);
    push(@gen_arity, $arity);
    $gen_opnum{$name,$arity} = $op_num;
    $gen_arity{$name} = $arity;
    $gen_to_spec{"$name/$arity"} = 0;
    $num_specific{"$name/$arity"} = 0;
    $min_window{"$name/$arity"} = 255;
}

#
# Produce output for the chosen target.
#

&$target;

#
# Produce output needed by the emulator/loader.
#

sub emulator_output {
    my($i);

    #
    # Inforamtion about opcodes (beam_opcodes.c).
    #
    $name = 'beam_opcodes.c';
    open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
    &comment('C');
    print '#include "sys.h"', "\n";
    print '#include "config.h"', "\n";
    print '#include "beam_opcodes.h"', "\n";
    print "\n";

    print "char tag_to_letter[] = {\n  ";
    for ($i = 0; $i < 8; $i++) {
	print "'$tag_type[$i]', ";
    }
    for (; $i < @tag_type; $i++) {
	print "'_', ";
    }
    print "\n};\n";
    print "\n";

    #
    # Generate code for specific ops.
    #
    my($spec_opnum) = 0;
    print "OpEntry opc[] = {\n";
    foreach $key (sort keys %specific_op) {
	$gen_to_spec{$key} = $spec_opnum;
	$num_specific{$key} = @{$specific_op{$key}};

	#
	# Pick up all instructions and manufacture sort keys; we must have
	# the most specific instructions appearing first (e.g. an 'x' operand
	# should be matched before 's' or 'd').
	#
	my(%items) = ();
	foreach (@{$specific_op{$key}}) {
	    my($name, $hot, @args) = @{$_};
	    my($sign) = join('', @args);

	    # The primitive types should sort before other types.
	    my($sort_key) = $sign;
	    eval "\$sort_key =~ tr/$significant_types/./";
	    $sort_key .= ":$sign";
	    $items{$sort_key} = [$name, $hot, $sign, @args];
	}

	#
	# Now call the generator for the sorted result.
	#
	foreach (sort keys %items) {
	    my($name, $hot, $sign, @args) = @{$items{$_}};
	    my $arity = @args;
	    my($instr) = "${name}_$sign";
	    $instr =~ s/_$//;

	    #
	    # Call a generator to calculate size and generate macros
	    # for the emulator.
	    #
	    my($size, $code, $pack) = &basic_generator($name, $hot, @args);

	    #
	    # Save the generated $code for later.
	    #
	    if (defined $code) {
		if ($hot) {
		    push(@{$hot_code{$code}}, $instr);
		} else {
		    push(@{$cold_code{$code}}, $instr);
		}
	    }

	    #
	    # Calculate the bit mask which should be used to match this
	    # instruction.
	    #
	    my($bits) = 0;
	    my($shift) = 8;
	    foreach (@args) {
		if (defined $type_bit{$_}) {
		    $bits = $bits << $shift | $type_bit{$_};
		}
	    }

	    printf "/* %3d */  ", $spec_opnum;
	    $print_name = $sign ne '' ? "${name}_$sign" : $name;
	    &init_item($print_name, sprintf("0x%X", $bits), $size, $pack, $sign, 0);
	    $op_to_name[$spec_opnum] = $instr;
	    $spec_opnum++;
	}
    }
    print "};\n\n";
    print "int num_instructions = $spec_opnum;\n\n";

    &tr_gen(@transformations);

    #
    # Print the generic instruction table.
    #

    print "GenOpEntry gen_opc[] = {\n";
    for ($i = 0; $i < @gen_opname; $i++) {
	if ($i == $num_file_opcodes) {
	    print "\n/*\n * Internal generic instructions.\n */\n\n";
	}
	my($name) = $gen_opname[$i];
	my($arity) = $gen_arity[$i];
	printf "/* %3d */  ", $i;
	if (!defined $name) {
	    &init_item("", 0, 0, 0, -1);
	} else {
	    my($key) = "$name/$arity";
	    my($tr) = defined $gen_transform_offset{$key} ?
		$gen_transform_offset{$key} : -1;
	    my($spec_op) = $gen_to_spec{$key};
	    my($num_specific) = $num_specific{$key};
	    $spec_op != 0 or $tr != -1 or
		&error("instruction $key has no specific instruction");
	    &init_item($name, $arity, $spec_op, $num_specific, $tr, $min_window{$key});
	}
    }
    print "};\n";

    #
    # Information about opcodes (beam_opcodes.h).
    #
    $name = 'beam_opcodes.h';
    open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
    &comment('C');
    print "#ifndef __OPCODES_H__\n";
    print "#define __OPCODES_H__\n\n";

    print "#define BEAM_FORMAT_NUMBER $BEAM_FORMAT_NUMBER\n";
    print "#define NUM_GENERIC_OPS ", scalar(@gen_opname), "\n";
    print "#define NUM_SPECIFIC_OPS ", scalar(@op_to_name), "\n";
    print "\n";

    for ($i = 0; $i < @tag_type; $i++) {
	print "#define TAG_$tag_type[$i] $i\n";
    }
    print "\n";

    $i = 0;
    foreach (sort keys %match_engine_ops) {
	print "#define $_ $i\n";
	$i++;
    }
    print "#define NUM_TOPS $i\n";
    print "\n";

    print "#define TE_MAX_WINDOW $te_max_window\n";
    print "#define TE_MAX_VARS $te_max_vars\n";
    print "\n";

    print "typedef struct gen_op_entry {\n";
    print "   char* name;\n";
    print "   int arity;\n";
    print "   int specific;\n";
    print "   int num_specific;\n";
    print "   int transform;\n";
    print "   int min_window;\n";
    print "} GenOpEntry;\n\n";

    print "extern char tag_to_letter[];\n";
    print "extern uint32 op_transform[];\n";
    print "extern GenOpEntry gen_opc[];\n";
    print "extern void** beam_ops;\n";
    print "\n";

    for ($i = 0; $i < @op_to_name; $i++) {
	print "#define op_$op_to_name[$i] $i\n";
    }
    print "\n";

    print "#define NUMBER_OF_OPCODES ",scalar(@op_to_name),"\n";
    for ($i = 0; $i < @op_to_name; $i++) {
	print "#define op_count_$op_to_name[$i] ",$i+scalar(@op_to_name),"\n";
    }
    print "\n";

    print "#define DEFINE_OPCODES";
    foreach (@op_to_name) {
	print " \\\n&&lb_$_,";
    }
    print "\n\n";

    print "#define DEFINE_COUNTING_OPCODES";
    foreach (@op_to_name) {
	print " \\\n&&lb_count_$_,";
    }
    print "\n\n";

    print "#define DEFINE_COUNTING_LABELS";
    for ($i = 0; $i < @op_to_name; $i++) {
	my($name) = $op_to_name[$i];
	print " \\\nCountCase($name): opc[$i].count++; goto lb_$name;";
    }
    print "\n\n";

    print "#endif\n";

    #
    # Implementation of operations for emulator.
    #
    $name = "beam_hot.h";
    open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
    &comment('C');
    &print_code(\%hot_code);

    $name = "beam_cold.h";
    open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
    &comment('C');
    &print_code(\%cold_code);
}

sub init_item {
    my($sep) = "";

    print "{";
    foreach (@_) {
	if (!defined $_) {
	    print "${sep}NULL";
	} elsif (/^-?\d/) {
	    print "$sep$_";
	} else {
	    print "$sep\"$_\"";
	}
	$sep = ", ";
    }
    print "},\n";
}

sub q {
    my($str) = @_;
    "\"$str\"";
}

sub print_code {
    my($ref) = @_;
    my(%sorted);

    foreach $key (keys %$ref) {
	my($sort_key);
	my($code) = '';
	foreach $label (@{$ref->{$key}}) {
	    $code .= "OpCase($label):\n";
	    $sort_key = $label;
	}
	foreach (split("\n", $key)) {
	    $code .= "    $_\n";
	}
	$code .= "\n";
	$sorted{$sort_key} = $code;
    }

    foreach (sort keys %sorted) {
	print $sorted{$_};
    }
}

#
# Produce output needed by the compiler back-end (assembler).
#

sub compiler_output {
    my($module) = 'beam_opcodes';
    my($name) = "${module}.erl";

    open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
    print "-module($module).\n";
    &comment('erlang');

    print "-export([format_number/0]).\n";
    print "-export([opcode/2]).\n";
    print "\n";
    print "format_number() -> $BEAM_FORMAT_NUMBER.\n\n";

    for ($i = 0; $i < @gen_opname; $i++) {
	next unless defined $gen_opname[$i];
	print "opcode(", &quote($gen_opname[$i]), ", $gen_arity[$i]) -> $i;\n";
    }
    print "opcode(Name, Arity) -> exit({badarg, {opcode, [Name, Arity]}}).\n";

    #
    # Generate .hrl file.
    #
    my($name) = "${module}.hrl";
    open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
    &comment('erlang');

    for ($i = 0; $i < @tag_type; $i++) {
	print "-define(tag_$tag_type[$i], $i).\n";
    }
    print "\n";

}

#
# Check an operation for validity.
#
sub syntax_check {
    my($name, @args) = @_;
    my($i);

    &error("Bad opcode name '$name'")
	unless $name =~ /^[a-z][\w\d_]*$/;
    for ($i = 0; $i < @args; $i++) {
	&error("Argument " . ($i+1) . ": invalid type '$args[$i]'")
	    unless defined $arg_size{$args[$i]};
    }
}

sub error {
    my($string) = @_;
    die "Line $.: $string\n";
}


sub comment {
    my($lang, @comments) = @_;
    my($prefix);
    if ($lang eq 'C') {
	print "/*\n";
	$prefix = " * ";
    } elsif ($lang eq 'erlang') {
	$prefix = '%% ';
    } else {
	$prefix = '# ';
    }
    my(@prog) = split('/', $0);
    my($prog) = $prog[$#prog];

    print "$prefix Warning: Do not edit this file.  It was automatically\n";
    print "$prefix generated by '$prog' on ", (scalar localtime), ".\n";
    if ($lang eq 'C') {
	print " */\n";
    }
    print "\n";
}

#
# Basic implementation of instruction in emulator loop
# (assuming no packing).
#

sub basic_generator {
    my($name, $hot, @args) = @_;
    my($size) = 0;
    my($macro) = '';
    my($flags) = '';
    my(@f);
    my(@f_types);
    my($fail_type);
    my($prefix) = '';
    my($tmp_arg_num) = 1;
    my($pack_spec) = '';
    my($use_prefetch) = 1;
    my($i);

    # The following argument types should be included as macro arguments.
    my(%incl_arg) = ('c' => 1,
		     'i' => 1,
		     'a' => 1,
		     'A' => 1,
		     'N' => 1,
		     'u' => 1,
		     'I' => 1,
		     'P' => 1,
		     );

    # Pick up the macro to use and its flags (if any).

    $macro = $macro{$name} if defined $macro{$name};
    $flags = $macro_flags{$name} if defined $macro_flags{$name};

    #
    # Add any arguments to be included as macro arguments (for instance,
    # 'p' is usually not an argument, except for calls).
    #

    while ($flags =~ /-arg_(\w)/g) {
	$incl_arg{$1} = 1;
    };

    #
    # Pack arguments if requested.
    #

    if ($flags =~ /-pack/ && $hot) {
	($prefix, $pack_spec, @args) = &do_pack(@args);
    }

    #
    # Calculate the size of the instruction and generate each argument for
    # the macro.
    #

    foreach (@args) {
	my($this_size) = $arg_size{$_};
      SWITCH:
	{
	    /^pack:(\d):(.*)/ and do { push(@f, $2);
				       push(@f_types, 'packed');
				       $this_size = $1;
				       last SWITCH;
				   };
	    /r/    and do { push(@f, "r(0)"); push(@f_types, $_); last SWITCH };
	    /[xy]/ and do { push(@f, "$_" . "b(Arg($size))");
			     push(@f_types, $_);
			     last SWITCH;
			};
	    /n/    and do { push(@f, "NIL"); push(@f_types, $_); last SWITCH };
	    /s/    and do { my($tmp) = "tmp_arg$tmp_arg_num";
			    $tmp_arg_num++;
			    push(@f, $tmp);
			    push(@f_types, $_);
			    $prefix .= "GetR($size, $tmp);\n";
			    last SWITCH; };
	    /d/    and do { $macro .= "GenDest";
			    push(@f, "t0");
			    push(@f_types, $_);
			    $prefix .= "GetDest($size, t0);\n";
			    last SWITCH;
			};
	    defined($incl_arg{$_})
		and do { push(@f, "Arg($size)");
			 push(@f_types, $_);
			 last SWITCH;
		     };

	    /[fp]/ and do { $fail_type = $_; last SWITCH };

	    /[eLIFEbASjP]/ and do { last SWITCH; };

	    die "$name: The generator can't handle $_, at";
	}
	$size += $this_size;
    }

    #
    # If requested, pass a pointer to the destination register.
    # The destination must the last operand.
    #
    if ($flags =~ /-dest_ptr/) {
	$use_prefetch = 0;
	if ($f[$#f] eq 'r(0)') {
	    $f[$#f] = 'NULL';
	} else {
	    $f[$#f] = "&($f[$#f])";
	}
    }

    #
    # Add a fail action macro if requested.
    #

    $flags =~ /-fail_action/ and do {
	if (!defined $fail_type) {
	    my($i);
	    for ($i = 0; $i < @f_types; $i++) {
		local($_) = $f_types[$i];
		/[rxycians]/ and do { push(@f, "BadmatchSearch($f[$i])"); next };
	    }
	} elsif ($fail_type eq 'f') {
	    push(@f, "ClauseFail()");
	} else {
	    my($i);
	    for ($i = 0; $i < @f_types; $i++) {
		local($_) = $f_types[$i];
		/[rxycians]/ and do { push(@f, "Badmatch($f[$i])"); next };
	    }
	}
    };

    #
    # Add a size argument if requested.
    #

    $flags =~ /-size/ and do {
	push(@f, $size);
    };

    #
    # Generate a unique label if requested.
    #

    $flags =~ /-gen_label/ and do {
	push(@f, "_lbl__$unique_label");
	$unique_label++;
    };

    # Generate the macro if requested.
    my($code);
    if (defined $macro{$name}) {
	my($macro_code) = "$prefix$macro(" . join(', ', @f) . ");";

	if ($flags =~ /-nonext/) {
	    $code = "$macro_code\n";
	} elsif ($use_prefetch) {
	    $code = "Fetch($size);\n$macro_code\nNextF($size);\n";
	} else {
	    $code = "FetchAlt($size);\n$macro_code\nNextFAlt($size);\n";
#	    $code = "$macro_code\nNext($size);\n";
	}
    }

    # Return the size and code for the macro (if any).
    $size++;
    ($size, $code, $pack_spec);
}

sub do_pack {
    my(@args) = @_;
    my($i);
    my($size) = 0;
    my($pack_prefix) = '';
    my($down) = '';		# Pack commands (towards instruction
				# beginning).
    my($up) = '';		# Pack commands (storing back while
				# moving forward).
    my($packable_args) = 0;

    #
    # Count the number of packable arguments.  If we encounter any 's' or 'd'
    # arguments, packing is not possible.
    #
    for ($i = 0; $i < @args; $i++) {
	if ($args[$i] =~ /[xy]/) {
	    $packable_args++;
	} elsif ($args[$i] =~ /[sd]/) {
	    return ('', '', @args);
	}
    }

    #
    # Get out of here if too few or too many arguments.
    #
    return ('', '', @args) if $packable_args < 2;
    &error("too many packable arguments") if $packable_args > 4;
    my($args_per_word) = $packable_args < 4 ? $packable_args : 2;
    my(@shift) = @{$pack_shift[$args_per_word]};
    my(@mask) = @{$pack_mask[$args_per_word]};
    my(@pack_instr) = @{$pack_instr[$args_per_word]};

    my($ap) = 0;		# Argument number within word.
    my($tmpnum) = 1;		# Number of temporary variable.
    my($expr) = '';
    for ($i = 0; $i < @args; $i++) {
	my($reg) = $args[$i];
	my($this_size) = $arg_size{$reg};
	if ($reg =~ /[xy]/) {
	    $this_size = 0;

	    if ($ap == 0) {
		$pack_prefix .= "tmp_arg$tmpnum = Arg($size);\n";
		$up .= "p";
		$down = "P$down";
		$this_size = 1;
	    }

	    $down = "$pack_instr[$ap]$down";
	    my($unpack) = &make_unpack($tmpnum, $shift[$ap], $mask[$ap]);
	    $args[$i] = "pack:$this_size:$reg" . "b($unpack)";

	    if (++$ap == $args_per_word) {
		$ap = 0;
		$tmpnum++;
	    }
	} elsif ($arg_size{$reg} && $ap != 0) {
	    $down = "g${down}";
	    $up = "${up}p";
	}
	$size += $this_size;
    }

    $pack_spec = $down . $up;
    return ($pack_prefix, $pack_spec, @args);
}

sub make_unpack {
    my($tmpnum, $shift, $mask) = @_;

    my($e) = "tmp_arg$tmpnum";
    $e = "($e>>$shift)" if $shift;
    $e = sprintf("%s&0x%X", $e, $mask) unless $mask == $WHOLE_WORD;
    $e;
}

sub quote {
    local($_) = @_;
    return "'$_'" if $_ eq 'catch';
    return "'$_'" if $_ eq 'receive';
    return "'$_'" if $_ =~ /^[A-Z]/;
    $_;
}

#
# Parse instruction transformations when they first appear.
#
sub parse_transformation {
    local($_) = @_;
    my($orig) = $_;
    my($expr_mask);
    my($expr_val);

    if (s/^\[(.*?)\]//) {
	($expr_mask, $expr_val) = &parse_expr($1);
    }

    my($from, $to) = split(/\s*=>\s*/);
    my(@from) = split(/\s*\|\s*/, $from);
    my(@to)   = split(/\s*\|\s*/, $to);
    my(@op);

    $te_max_window = @from if $te_max_window < @from;
    $te_max_window = @to if $te_max_window < @to;

    foreach (@from) {
	(@op) = split;
	$_ = &compile_transform(1, @op);
    }

    foreach (@to) {
	(@op) = split;
	$_ = &compile_transform(0, @op);
    }

    push(@transformations, [$., $orig, $expr_mask, $expr_val, @from, @to]);
}

sub parse_expr {
    my($expr, $line) = @_;

    if ($expr eq 'tr') {
	return (1, 1);
    } elsif ($expr eq '!tr') {
	return (1, 0);
    } else {
	&error("bad expression in transformation: [$expr]");
    }
}

sub compile_transform {
    my($src, $name, @ops) = @_;
    
    foreach (@ops) {
	$_ = [ &tr_parse_op($src, $_) ];
    }
    [$src, $name, @ops];
}

sub tr_parse_op {
    my($src, $op) = @_;
    my($var) = '';
    my($type) = '';
    my($cond) = '';
    my($cond_val) = '';

    local($_) = $op;

    # Get the variable name if any.

    if (/^([A-Z]\w*)(.*)/) {
	$var = $1;
	$_ = $2;
	&error("garbage after variable")
	    unless /^=(.*)/ or /^(\s*)$/;
	$_ = $1;
    }

    # Get the type if any.

    if (/^([a-z]+)(.*)/) {
	$type = $1;
	$_ = $2;
	foreach (split('', $type)) {
	    &error("bad type in $op")
		unless defined $type_bit{$_};
	}
    }

    # Get an optional condition.  Only '=' condition is supported now.
    if (/^==(.*)/) {
	$cond = 'eq';
	$cond_val = $1;
	$_ = '';
    }

    # Nothing more.
    &error("garbage after operand: $op")
	unless /^\s*$/;

    # Test that destination has no conditions.
    unless ($src) {
	&error("condition not allowed in destination: $op")
	    if $cond;
	&error("variable name and type cannot be combined in destination: $op")
	    if $var && $type;
    }

    ($var, $type, $cond, $cond_val);
}

#
# Generate code for all transformations.
#

sub tr_gen {
    my(@g) = @_;
    foreach $ref (@g) {
	my($line, $orig_transform, $expr_mask, $expr_val, @tr) = @$ref;
	tr_gen1($line, $orig_transform, $expr_mask, $expr_val, @tr);
    }

    #
    # Print the generated transformation engine.
    #
    my($offset) = 0;
    print "uint32 op_transform[] = {\n";
    foreach $key (keys %gen_transform) {
	$gen_transform_offset{$key} = $offset;
	foreach $instr (@{$gen_transform{$key}}) {
	    my($size, $instr_ref, $comment) = @$instr;
	    my($op, @args) = @$instr_ref;
	    print "    ";
	    if (!defined $op) {
		$comment =~ s/\n(.)/\n    $1/g;
		print "\n", $comment;
	    } else {
		$op = "TOP_$op";
		$match_engine_ops{$op} = 1;
		if ($comment ne '') {
		    printf "%-24s /* %s */\n", (join(", ", ($op, @args)) . ","),
		    $comment;
		} else {
		    print join(", ", ($op, @args)), ",\n";
		}
		$offset += $size;
	    }
	}
	print "\n";
    }
    print "};\n\n";
}

sub tr_gen1 {
    my($line, $orig_transform, $mask, $val, @tr) = @_;
    my(%var) = ();
    my($var_num) = 0;
    my(@code);
    my($first_dest) = 1;
    my($min_window) = 0;

    foreach $ref (@tr) {
	my($src, $name, @ops) = @$ref;
	my $arity = @ops;
	my($key) = "$name/$arity";
	my($opnum);

	&error("transformation in line $line: invalid generic op $name/$arity")
	    unless defined $gen_opnum{$name,$arity};
	$opnum = $gen_opnum{$name,$arity};

	if ($src) {
 	    push(@code, &make_op("$name/$arity", 'is_op', $opnum));
	    $min_window++;
	    foreach $op (@ops) {
		my($var, $type, $cond, $val) = @$op;
		if ($type ne '') {
		    my($types) = '';
		    my($type_mask) = 0;
		    foreach (split('', $type)) {
			$types .= "$_ ";
			$type_mask |= $type_bit{$_};
		    }
		    push(@code, &make_op($types, 'is_type', $type_mask));
		}

		if ($cond ne '') {
		    push(@code, &make_op('', "is_$cond", $val));
		}

		if ($var ne '') {
		    if (defined $var{$var}) {
			push(@code, &make_op($var, 'is_same_var', $var{$var}));
		    } else {
			$var{$var} = $var_num;
			$var_num++;
			push(@code, &make_op($var, 'set_var', $var{$var}));
		    }
		}
		push(@code, &make_op('', 'next_arg'));
	    }
	} else {
	    if ($first_dest) {
		pop(@code);	# Get rid of 'next_instr'
		push(@code, &make_op('', 'commit'));
		$first_dest = 0;
	    }
	    push(@code, &make_op("$name/$arity", 'store_op', $opnum, $arity));
	    foreach $op (@ops) {
		my($var, $type) = @$op;

		if ($var ne '') {
		    push(@code, &make_op($var, 'store_var', $var{$var}));
		} elsif ($type ne '') {
		    push(@code, &make_op('', 'store_type', "TAG_$type"));
		}
		push(@code, &make_op('', 'next_arg'));
	    }
	}

	pop(@code) if $code[$#code]->[1][0] eq 'next_arg';
	push(@code, &make_op('', 'next_instr'));
    }

    #
    # We need a commit in case there is no destination (deletion of instructions).
    #
    if ($first_dest) {
	pop(@code);		# Get rid of 'next_instr'
	push(@code, &make_op('', 'commit'));
	$first_dest = 0;
    }

    if (defined $mask && defined $val) {
	splice(@code, 1, 0, &make_op("", 'test', $mask, $val));
    }

    push(@code, &make_op('', 'end'));
    $te_max_vars = $var_num if $te_max_vars < $var_num;

    #
    # Chain together all codes segments having the same first operation.
    #
    my($first_ref) = shift(@code);
    my($size, $first, $key) = @$first_ref;
    my($dummy, $op, $arity) = @$first;
    my($comment) = "\n/*\n * Line $line:\n *   $orig_transform\n */\n\n";
    $min_window{$key} = $min_window if $min_window{$key} > $min_window;

    pop(@{$gen_transform{$key}})
	if defined @{$gen_transform{$key}}; # Fail
    my(@prefix) = (&make_op($comment), &make_op('', 'try_me_else', &tr_code_len(@code)));
    unshift(@code, @prefix);
    push(@{$gen_transform{$key}}, @code, &make_op('', 'fail'));
}

sub tr_code_len {
    my($sum) = 0;

    foreach $ref (@_) {
	$sum += $$ref[0];
    }
    $sum;
}

sub make_op {
    my($comment, @op) = @_;
    [scalar(@op), [@op], $comment];
}
