beam_makeops

OTP是开放电信平台的简称

#!/usr/bin/env perl
# ``The contents of this file are subject to the Erlang Public License,
# Version 1.1, (the "License"); you may not use this file except in
# compliance with the License. You should have received a copy of the
# Erlang Public License along with this software. If not, it can be
# retrieved via the world wide web at http://www.erlang.org/.
# 
# Software distributed under the License is distributed on an "AS IS"
# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
# the License for the specific language governing rights and limitations
# under the License.
# 
# The Initial Developer of the Original Code is Ericsson Utvecklings AB.
# Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings
# AB. All Rights Reserved.''
# 
#     $Id$
#

use strict;
use vars qw($BEAM_FORMAT_NUMBER);

$BEAM_FORMAT_NUMBER = undef;

my $target = \&emulator_output;
my $outdir = ".";		# Directory for output files.
my $verbose = 0;
my $hot = 1;
my $num_file_opcodes = 0;

# This is shift counts and mask for the packer.
my $WHOLE_WORD = '';
my @pack_instr;
my @pack_shift;
my @pack_mask;

$pack_instr[2] = ['6', 'i'];
$pack_instr[3] = ['0', '0', 'i'];

$pack_shift[2] = ['0', 'BEAM_LOOSE_SHIFT'];
$pack_shift[3] = ['0', 'BEAM_TIGHT_SHIFT', '(2*BEAM_TIGHT_SHIFT)'];

$pack_mask[2]  = ['BEAM_LOOSE_MASK', $WHOLE_WORD];
$pack_mask[3]  = ['BEAM_TIGHT_MASK', 'BEAM_TIGHT_MASK', 'BEAM_TIGHT_MASK'];

# Maximum number of operands for a specific instruction.
# Must be even. The beam_load.c file must be updated, too.
my $max_operands = 6;

my %gen_opnum;
my %num_specific;
my %gen_to_spec;
my %specific_op;

my %gen_arity;
my @gen_arity;

my @gen_opname;
my @op_to_name;

my %macro;
my %macro_flags;

my %hot_code;
my %cold_code;

my @unnumbered_generic;
my %unnumbered;

#
# Code transformations.
#
my $te_max_vars = 0;		# Max number of variables ever needed.
my %gen_transform;
my %min_window;
my %match_engine_ops;		# All opcodes for the match engine.
my %gen_transform_offset;
my @transformations;
my @call_table;
my @pred_table;

# Operand types for generic instructions.

my $compiler_types = "uiaxyfhz";
my $loader_types = "nprowvl";
my $genop_types = $compiler_types . $loader_types;

#
# Defines the argument types and their loaded size assuming no packing.
#
my %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
		'j' => 1,	# either 'f' or 'p'
		'e' => 1,	# pointer to export entry
		'L' => 0,	# label
		'I' => 1,	# untagged integer
		't' => 1,	# untagged integer -- can be packed
		'b' => 1,	# pointer to bif
		'A' => 1,	# arity value
		'P' => 1,	# byte offset into tuple
		'o' => 2,	# float
		'w' => 1,	# bignumber
		'h' => 1,	# character
		'l' => 1,	# float reg
	     );

#
# Generate bits.
#
my %type_bit;
my @tag_type;

{
    my($bit) = 1;
    my(%bit);

    foreach (split('', $genop_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 (for matching purposes).
    $type_bit{'I'} = $type_bit{'u'};
    $type_bit{'t'} = $type_bit{'u'};
    $type_bit{'A'} = $type_bit{'u'};
    $type_bit{'L'} = $type_bit{'u'};
    $type_bit{'b'} = $type_bit{'u'};
    $type_bit{'N'} = $type_bit{'u'};
    $type_bit{'U'} = $type_bit{'u'};
    $type_bit{'e'} = $type_bit{'u'};
    $type_bit{'P'} = $type_bit{'u'};
}

#
# Parse command line options.
#

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

#
# Parse the input files.
#

while (<>) {
    my($op_num);
    chomp;
    if (s/\\$//) {
	$_ .= <>;
	redo unless eof(ARGV);
    }
    next if /^\s*$/;
    next if /^\#/;
    
    #
    # Handle assignments.
    #
    if (/^([\w_][\w\d_]+)=(.*)/) {
	no strict 'refs';
	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");
	}
	error("Macro for '$op' is already defined")
	    if defined $macro{$op};
	$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 already defined")
	    if defined $gen_opname[$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"} = undef;
	    $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;
    &error("too many operands")
	if @args > $max_operands;
    &syntax_check($name, @args);
    my $arity = @args;
    push(@{$specific_op{"$name/$arity"}}, [$name, $hot, @args]);
    if (defined $op_num) {
	&error("specific instructions must not be numbered");
    } elsif (!defined($gen_arity{$name}) && !defined($unnumbered{$name,$arity})) {
	#
	# Create an unumbered generic instruction too.
	#
	push(@unnumbered_generic, [$name, $arity]);
	$unnumbered{$name,$arity} = 1;
    }
} continue {
    close(ARGV) if eof(ARGV);
}

$num_file_opcodes = @gen_opname;

#
# Number all generic operations without numbers.
#
{
    my $ref;

    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"} = undef;
	$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;
    my $name;
    my $key;			# Loop variable.

    #
    # Information about opcodes (beam_opcodes.c).
    #
    $name = "$outdir/beam_opcodes.c";
    open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
    &comment('C');
    print "#ifdef HAVE_CONFIG_H\n";
    print "#  include \"config.h\"\n";
    print "#endif\n\n";
    print '#include "sys.h"', "\n";
    print '#include "erl_vm.h"', "\n";
    print '#include "export.h"', "\n";
    print '#include "erl_process.h"', "\n";
    print '#include "bif.h"', "\n";
    print '#include "erl_atom_table.h"', "\n";
    print '#include "beam_load.h"', "\n";
    print "\n";

    print "char tag_to_letter[] = {\n  ";
    for ($i = 0; $i < length($genop_types); $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/$genop_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) x ($max_operands/2);
	    my($shift) = 16;
	    my($i);
	    for ($i = 0; $i < $max_operands && defined $args[$i]; $i++) {
		my $t = $args[$i];
		if (defined $type_bit{$t}) {
		    $bits[int($i/2)] |= $type_bit{$t} << (16*($i%2));
		}
	    }

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

    #
    # Generate transformations.
    #

    &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};
	    defined $spec_op or $tr != -1 or
		&error("instruction $key has no specific instruction");
	    $spec_op = -1 unless defined $spec_op;
	    &init_item($name, $arity, $spec_op, $num_specific, $tr, $min_window{$key});
	}
    }
    print "};\n";

    #
    # Information about opcodes (beam_opcodes.h).
    #
    $name = "$outdir/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 MAX_GENERIC_OPCODE ", $num_file_opcodes-1, "\n";
    print "#define NUM_GENERIC_OPS ", scalar(@gen_opname), "\n";
    print "#define NUM_SPECIFIC_OPS ", scalar(@op_to_name), "\n";
    print "\n";
    print "#ifdef ARCH_64\n";
    print "#  define BEAM_LOOSE_MASK 0x1FFFUL\n";
    print "#  define BEAM_TIGHT_MASK 0x1FF8UL\n";
    print "#  define BEAM_LOOSE_SHIFT 16\n";
    print "#  define BEAM_TIGHT_SHIFT 16\n";
    print "#else\n";