Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

executable file 1618 lines (1401 sloc) 39.998 kB
#!/usr/bin/env perl
#
# %CopyrightBegin%
#
# Copyright Ericsson AB 1998-2011. All Rights Reserved.
#
# 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 online 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.
#
# %CopyrightEnd%
#
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;
my $wordsize = 32;
# 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_instr[4] = ['6', '6', '6', 'i']; # Only for 64 bit wordsize
$pack_shift[2] = ['0', 'BEAM_LOOSE_SHIFT'];
$pack_shift[3] = ['0', 'BEAM_TIGHT_SHIFT', '(2*BEAM_TIGHT_SHIFT)'];
$pack_shift[4] = ['0', 'BEAM_LOOSE_SHIFT', # Only for 64 bit wordsize
'(2*BEAM_LOOSE_SHIFT)',
'(3*BEAM_LOOSE_SHIFT)'];
$pack_mask[2] = ['BEAM_LOOSE_MASK', $WHOLE_WORD];
$pack_mask[3] = ['BEAM_TIGHT_MASK', 'BEAM_TIGHT_MASK', 'BEAM_TIGHT_MASK'];
$pack_mask[4] = ['BEAM_LOOSE_MASK', # Only for 64 bit wordsize
'BEAM_LOOSE_MASK',
'BEAM_LOOSE_MASK',
$WHOLE_WORD];
# There are two types of instructions: generic and specific.
# The generic instructions are those generated by the Beam compiler.
# Corresponding to each generic instruction, there is generally a
# whole family of related specific instructions. Specific instructions
# are those executed by the VM interpreter during run-time.
# Maximum number of operands for a generic instruction.
# In beam_load.c the MAX_OPARGS refers to the maximum
# number of operands for generic instructions.
my $max_gen_operands = 8;
# Maximum number of operands for a specific instruction.
# Must be even. The beam_load.c file must be updated, too.
my $max_spec_operands = 6;
# The maximum number of primitive genop_types.
my $max_genop_types = 16;
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 @obsolete;
my %macro;
my %macro_flags;
my %hot_code;
my %cold_code;
my @unnumbered_generic;
my %unnumbered;
my %is_transformed;
#
# 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 = "nprvlqo";
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 or stack
'Q' => 1, # like 'P', but packable
'h' => 1, # character
'l' => 1, # float reg
'q' => 1, # literal term
);
#
# Generate bits.
#
my %type_bit;
my @tag_type;
sub define_type_bit {
my($tag,$val) = @_;
defined $type_bit{$tag} and
sanity("the tag '$tag' has already been defined with the value ",
$type_bit{$tag});
$type_bit{$tag} = $val;
}
{
my($bit) = 1;
my(%bit);
foreach (split('', $genop_types)) {
push(@tag_type, $_);
define_type_bit($_, $bit);
$bit{$_} = $bit;
$bit *= 2;
}
# Composed types.
define_type_bit('d', $type_bit{'x'} | $type_bit{'y'} | $type_bit{'r'});
define_type_bit('c', $type_bit{'i'} | $type_bit{'a'} |
$type_bit{'n'} | $type_bit{'q'});
define_type_bit('s', $type_bit{'d'} | $type_bit{'i'} |
$type_bit{'a'} | $type_bit{'n'});
define_type_bit('j', $type_bit{'f'} | $type_bit{'p'});
# Aliases (for matching purposes).
define_type_bit('I', $type_bit{'u'});
define_type_bit('t', $type_bit{'u'});
define_type_bit('A', $type_bit{'u'});
define_type_bit('L', $type_bit{'u'});
define_type_bit('b', $type_bit{'u'});
define_type_bit('N', $type_bit{'u'});
define_type_bit('U', $type_bit{'u'});
define_type_bit('e', $type_bit{'u'});
define_type_bit('P', $type_bit{'u'});
define_type_bit('Q', $type_bit{'u'});
}
#
# Sanity checks.
#
{
if (@tag_type > $max_genop_types) {
sanity("\$max_genop_types is $max_genop_types, ",
"but there are ", scalar(@tag_type),
" primitive tags defined\n");
}
foreach my $tag (@tag_type) {
sanity("tag '$tag': primitive tags must be named with lowercase letters")
unless $tag =~ /^[a-z]$/;
}
}
#
# 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/;
($wordsize = shift), next if /^wordsize/;
($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($obsolete) = $1;
my($name) = $2;
my($arity) = $3;
$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;
$obsolete[$op_num] = $obsolete eq '-';
} 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_spec_operands;
&syntax_check($name, @args);
my $arity = @args;
if ($obsolete[$gen_opnum{$name,$arity}]) {
error("specific instructions may not be specified for obsolete instructions");
}
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_spec_operands/2);
my($i);
for ($i = 0; $i < $max_spec_operands && defined $args[$i]; $i++) {
my $t = $args[$i];
if (defined $type_bit{$t}) {
my $shift = $max_genop_types * ($i % 2);
$bits[int($i/2)] |= $type_bit{$t} << $shift;
}
}
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
$obsolete[$gen_opnum{$name,$arity}] or
$is_transformed{$name,$arity} 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_WIDE_MASK 0xFFFFUL\n";
print "# define BEAM_LOOSE_MASK 0x1FFFUL\n";
print "#if HALFWORD_HEAP\n";
print "# define BEAM_TIGHT_MASK 0x1FFCUL\n";
print "#else\n";
print "# define BEAM_TIGHT_MASK 0x1FF8UL\n";
print "#endif\n";
print "# define BEAM_WIDE_SHIFT 32\n";
print "# define BEAM_LOOSE_SHIFT 16\n";
print "# define BEAM_TIGHT_SHIFT 16\n";
print "#else\n";
print "# define BEAM_LOOSE_MASK 0xFFF\n";
print "# define BEAM_TIGHT_MASK 0xFFC\n";
print "# define BEAM_LOOSE_SHIFT 16\n";
print "# define BEAM_TIGHT_SHIFT 10\n";
print "#endif\n";
print "\n";
#
# Definitions of tags.
#
my $letter;
my $tag_num = 0;
&comment('C', "The following operand types for generic instructions",
"occur in beam files.");
foreach $letter (split('', $compiler_types)) {
print "#define TAG_$letter $tag_num\n";
$tag_num++;
}
print "\n";
&comment('C', "The following operand types are only used in the loader.");
foreach $letter (split('', $loader_types)) {
print "#define TAG_$letter $tag_num\n";
$tag_num++;
}
print "\n#define BEAM_NUM_TAGS $tag_num\n\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_VARS $te_max_vars\n";
print "\n";
print "extern char tag_to_letter[];\n";
print "extern Uint op_transform[];\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";
for ($i = 0; $i < @gen_opname; $i++) {
print "#define genop_$gen_opname[$i]_$gen_arity[$i] $i\n"
if defined $gen_opname[$i];
}
print "#endif\n";
#
# Extension of transform engine.
#
$name = "$outdir/beam_tr_funcs.h";
open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
&comment('C');
&tr_gen_call(@call_table);
$name = "$outdir/beam_pred_funcs.h";
open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
&comment('C');
&tr_gen_call(@pred_table);
#
# Implementation of operations for emulator.
#
$name = "$outdir/beam_hot.h";
open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
&comment('C');
&print_code(\%hot_code);
$name = "$outdir/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 (/^\{/) {
print "$sep$_";
} elsif (/^-?\d/) {
print "$sep$_";
} else {
print "$sep\"$_\"";
}
$sep = ", ";
}
print "},\n";
}
sub q {
my($str) = @_;
"\"$str\"";
}
sub print_code {
my($ref) = @_;
my(%sorted);
my($key, $label); # Loop variables.
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";
my($i);
open(STDOUT, ">$outdir/$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,opname/1]).\n";
print "\n";
print "-spec format_number() -> $BEAM_FORMAT_NUMBER.\n";
print "format_number() -> $BEAM_FORMAT_NUMBER.\n\n";
print "-spec opcode(atom(), 0..", $max_gen_operands, ") -> 1..", $num_file_opcodes-1, ".\n";
for ($i = 0; $i < @gen_opname; $i++) {
next unless defined $gen_opname[$i];
print "%%" if $obsolete[$i];
print "opcode(", &quote($gen_opname[$i]), ", $gen_arity[$i]) -> $i;\n";
}
print "opcode(Name, Arity) -> erlang:error(badarg, [Name,Arity]).\n\n";
print "-spec opname(1..", $num_file_opcodes-1, ") -> {atom(),0..", $max_gen_operands, "}.\n";
for ($i = 0; $i < @gen_opname; $i++) {
next unless defined $gen_opname[$i];
print "opname($i) -> {",
&quote($gen_opname[$i]), ",$gen_arity[$i]};\n";
}
print "opname(Number) -> erlang:error(badarg, [Number]).\n";
#
# Generate .hrl file.
#
my($name) = "$outdir/${module}.hrl";
open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
&comment('erlang');
for ($i = 0; $i < @tag_type && $i < 8; $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(@message) = @_;
my($where) = $. ? "$ARGV($.): " : "";
die $where, @message, "\n";
}
sub sanity {
die "internal error: ", @_, "\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];
if (@comments) {
my $line;
foreach $line (@comments) {
print "$prefix$line\n";
}
} else {
print "$prefix Warning: Do not edit this file.\n";
print "$prefix Auto-generated by '$prog'.\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($var_decls) = '';
my($gen_dest_arg) = 'StoreSimpleDest';
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,
't' => 1,
'P' => 1,
'Q' => 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) = "targ$tmp_arg_num";
$var_decls .= "Eterm $tmp; ";
$tmp_arg_num++;
push(@f, $tmp);
push(@f_types, $_);
$prefix .= "GetR($size, $tmp);\n";
last SWITCH; };
/d/ and do { $var_decls .= "Eterm dst; ";
push(@f, "dst");
push(@f_types, $_);
$prefix .= "dst = Arg($size);\n";
$gen_dest_arg = 'StoreResult';
last SWITCH;
};
defined($incl_arg{$_})
and do { push(@f, "Arg($size)");
push(@f_types, $_);
last SWITCH;
};
/[fp]/ and do { $fail_type = $_; last SWITCH };
/[eLIFEbASjPowlq]/ 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 be the last operand.
#
if ($flags =~ /-gen_dest/) {
push(@f, $gen_dest_arg);
}
#
# 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, "Badmatch($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 the macro if requested.
my($code);
if (defined $macro{$name}) {
my($macro_code) = "$prefix$macro(" . join(', ', @f) . ");";
$var_decls .= "BeamInstr tmp_packed1;"
if $macro_code =~ /tmp_packed1/;
$var_decls .= "BeamInstr tmp_packed2;"
if $macro_code =~ /tmp_packed2/;
if ($flags =~ /-nonext/) {
$code = join("\n",
"{ $var_decls",
$macro_code,
"}");
} elsif ($flags =~ /-goto:(\S*)/) {
my $goto = $1;
$code = join("\n",
"{ $var_decls",
$macro_code,
"I += $size + 1;",
"goto $goto;",
"}");
} else {
$code = join("\n",
"{ $var_decls",
"BeamInstr* next;",
"PreFetch($size, next);",
"$macro_code",
"NextPF($size, next);",
"}", "");
}
}
# Return the size and code for the macro (if any).
$size++;
($size, $code, $pack_spec);
}
sub do_pack {
my(@args) = @_;
my($packable_args) = 0;
my @is_packable; # Packability (boolean) for each argument.
my $wide_packing = 0;
#
# Count the number of packable arguments. If we encounter any 's' or 'd'
# arguments, packing is not possible.
#
my $packable_types = "xytQ";
foreach my $arg (@args) {
if ($arg =~ /^[$packable_types]/) {
$packable_args++;
push @is_packable, 1;
} elsif ($arg =~ /^I/ and $wordsize == 64 and $packable_args < 2) {
$wide_packing = 1;
push @is_packable, 1;
if (++$packable_args == 2) {
# We can only pack two arguments. Turn off packing
# for the rest of the arguments.
$packable_types = "\xFF";
}
} elsif ($arg =~ /^[sd]/) {
return ('', '', @args);
} else {
push @is_packable, 0;
}
}
#
# 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($size) = 0;
my($pack_prefix) = '';
my($down) = ''; # Pack commands (towards instruction
# beginning).
my($up) = ''; # Pack commands (storing back while
# moving forward).
my $args_per_word;
if ($packable_args < 4 or $wordsize == 64) {
$args_per_word = $packable_args;
} else {
# 4 packable argument, 32 bit wordsize. Need 2 words.
$args_per_word = 2;
}
my @shift;
my @mask;
my @instr;
if ($wide_packing) {
@shift = ('0', 'BEAM_WIDE_SHIFT');
@mask = ('BEAM_WIDE_MASK', $WHOLE_WORD);
@instr = ('w', 'i');
} else {
@shift = @{$pack_shift[$args_per_word]};
@mask = @{$pack_mask[$args_per_word]};
@instr = @{$pack_instr[$args_per_word]};
}
#
# Now generate the packing instructions. One complication is that
# the packing engine works from right-to-left, but we must generate
# the instructions from left-to-right because we must calculate
# instruction sizes from left-to-right.
#
# XXX Packing 3 't's in one word won't work. Sorry.
my $did_some_packing = 0; # Nothing packed yet.
my($ap) = 0; # Argument number within word.
my($tmpnum) = 1; # Number of temporary variable.
my($expr) = '';
for (my $i = 0; $i < @args; $i++) {
my($reg) = $args[$i];
my($this_size) = $arg_size{$reg};
if ($is_packable[$i]) {
$this_size = 0;
$did_some_packing = 1;
if ($ap == 0) {
$pack_prefix .= "tmp_packed$tmpnum = Arg($size);\n";
$up .= "p";
$down = "P$down";
$this_size = 1;
}
$down = "$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} && $did_some_packing) {
#
# This is an argument that can't be packed. Normally, we must
# save it on the pack engine's stack, unless:
#
# 1. The argument has zero size (e.g. r(0)). Such arguments
# will not be loaded. They disappear.
# 2. If the argument is on the left of the first packed argument,
# the packing engine will never access it (because the engine
# operates from right-to-left).
#
$down = "g${down}";
$up = "${up}p";
}
$size += $this_size;
}
my $pack_spec = $down . $up;
return ($pack_prefix, $pack_spec, @args);
}
sub make_unpack {
my($tmpnum, $shift, $mask) = @_;
my($e) = "tmp_packed$tmpnum";
$e = "($e>>$shift)" if $shift;
$e .= "&$mask" unless $mask eq $WHOLE_WORD;
$e;
}
sub quote {
local($_) = @_;
return "'$_'" if $_ eq 'try';
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($from, $to) = split(/\s*=>\s*/);
my(@op);
# The source instructions.
my(@from) = split(/\s*\|\s*/, $from);
foreach (@from) {
if (/^(\w+)\((.*?)\)/) {
my($name, $arglist) = ($1, $2);
$_ = (&compile_transform_function($name, split(/\s*,\s*/, $arglist)));
} else {
(@op) = split;
$_ = &compile_transform(1, @op);
}
}
#
# Check for a function which should be called to provide the new
# instructions if the left-hand side matched. Otherwise there is
# an explicit list of instructions.
#
my @to;
if ($to =~ /^(\w+)\((.*?)\)/) {
my($name, $arglist) = ($1, $2);
@to = (&compile_transform_function($name, split(/\s*,\s*/, $arglist)));
} else {
@to = split(/\s*\|\s*/, $to);
foreach (@to) {
(@op) = split;
$_ = &compile_transform(0, @op);
}
}
push(@transformations, [$., $orig, [@from], [reverse @to]]);
}
sub compile_transform_function {
my($name, @args) = @_;
[".$name", 0, @args];
}
sub compile_transform {
my($src, $name, @ops) = @_;
my $arity = 0;
foreach (@ops) {
my(@list) = &tr_parse_op($src, $_);
$arity++ unless $list[1] eq '*';
$_ = [ @list ];
}
if ($obsolete[$gen_opnum{$name,$arity}]) {
error("obsolete function must not be used in transformations");
}
if ($src) {
$is_transformed{$name,$arity} = 1;
}
[$name,$arity,@ops];
}
sub tr_parse_op {
my($src, $op) = @_;
my($var) = '';
my($type) = '';
my($type_val) = 0;
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{$_} or $type eq '*';
}
}
# Get an optional condition. (In source.)
if (/^==(.*)/) {
$cond = 'is_eq';
$cond_val = $1;
$_ = '';
} elsif (/^\$is_bif(.*)/) {
$cond = 'is_bif';
$cond_val = -1;
$_ = $1;
} elsif (/^\$is_not_bif(.*)/) {
$cond = 'is_not_bif';
$cond_val = -1;
$_ = $1;
} elsif (m@^\$bif:(\w+):(\w+)/(\d)(.*)@) {
$cond = 'is_bif';
if ($1 eq 'erlang') {
$cond_val = "BIF_$2_$3";
} else {
$cond_val = "BIF_$1_$2_$3";
}
$_ = $4;
} elsif (m@^\$func:(\w+):(\w+)/([_\d])(.*)@) {
my $arity = $3 eq '_' ? 1024 : $3;
$cond = 'is_func';
$cond_val = "$1:$2:$arity";
$_ = $4;
}
# Get an optional value. (In destination.)
if (/^=(.*)/) {
$type_val = $1;
$_ = '';
}
# Nothing more is allowed after the command.
&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;
}
# Test that source has no values.
if ($src) {
error("value not allowed in source: $op")
if $type_val;
}
($var,$type,$type_val,$cond,$cond_val);
}
#
# Generate code for all transformations.
#
sub tr_gen {
my(@g) = @_;
my($ref, $key, $instr); # Loop variables.
foreach $ref (@g) {
my($line, $orig_transform, $from_ref, $to_ref) = @$ref;
my $so_far = tr_gen_from($line, @$from_ref);
tr_gen_to($line, $orig_transform, $so_far, @$to_ref);
}
#
# Print the generated transformation engine.
#
my($offset) = 0;
print "Uint 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";
print " * Total number of words: $offset\n";
print " */\n";
print "};\n\n";
}
sub tr_gen_from {
my($line, @tr) = @_;
my(%var) = ();
my(%var_type);
my($var_num) = 0;
my(@code);
my($min_window) = 0;
my(@fix_rest_args);
my(@fix_pred_funcs);
my($op, $ref); # Loop variables.
my $where = "left side of transformation in line $line: ";
foreach $ref (@tr) {
my($name, $arity, @ops) = @$ref;
my($key) = "$name/$arity";
my($opnum);
#
# A name starting with a period is a C pred function to be called.
#
if ($name =~ /^\.(\w+)/) {
$name = $1;
my $var;
my(@args);
my $next_instr = pop(@code); # Get rid of 'next_instr'
push(@fix_pred_funcs, scalar(@code));
push(@code, [$name, @ops]);
push(@code, $next_instr);
next;
}
#
# Check that $name/$arity refers to a valid generic instruction.
#
&error($where, "invalid generic op $name/$arity")
unless defined $gen_opnum{$name,$arity};
$opnum = $gen_opnum{$name,$arity};
push(@code, &make_op("$name/$arity", 'is_op', $opnum));
$min_window++;
foreach $op (@ops) {
my($var, $type, $type_val, $cond, $val) = @$op;
if ($type ne '' && $type ne '*') {
#
# The is_bif, is_not_bif, and is_func instructions have
# their own built-in type test and don't need to
# be guarded with a type test instruction.
#
unless ($cond eq 'is_bif' or
$cond eq 'is_not_bif' or
$cond eq 'is_func') {
my($types) = '';
my($type_mask) = 0;
foreach (split('', $type)) {
$types .= "$_ ";
$type_mask |= $type_bit{$_};
}
if ($cond ne 'is_eq') {
push(@code, &make_op($types, 'is_type', $type_mask));
} else {
$cond = '';
push(@code, &make_op($types, 'is_type_eq',
$type_mask, $val));
}
}
}
if ($cond eq 'is_func') {
my($m, $f, $a) = split(/:/, $val);
push(@code, &make_op('', "$cond", "am_$m",
"am_$f", $a));
} elsif ($cond ne '') {
push(@code, &make_op('', "$cond", $val));
}
if ($var ne '') {
if (defined $var{$var}) {
push(@code, &make_op($var, 'is_same_var', $var{$var}));
} elsif ($type eq '*') {
#
# Reserve a hole for a 'rest_args' instruction.
#
push(@fix_rest_args, scalar(@code));
push(@code, $var);
} else {
$var_type{$var} = 'scalar';
$var{$var} = $var_num;
$var_num++;
push(@code, &make_op($var, 'set_var', $var{$var}));
}
}
if (is_set_var_instr($code[$#code])) {
my $ref = pop @code;
my $comment = $ref->[2];
my $var = $ref->[1][1];
push(@code, make_op($comment, 'set_var_next_arg', $var));
} else {
push(@code, &make_op('', 'next_arg'));
}
}
push(@code, &make_op('', 'next_instr'));
pop(@code) if $code[$#code]->[1][0] eq 'next_arg';
}
#
# Insert the commit operation.
#
pop(@code); # Get rid of 'next_instr'
push(@code, &make_op('', 'commit'));
#
# If there is an rest_args instruction, we must insert its correct
# variable number (higher than any other).
#
my $index;
&error("only one use of a '*' variable is allowed on the left hand side of a transformation")
if @fix_rest_args > 1;
foreach $index (@fix_rest_args) {
my $var = $code[$index];
$var{$var} = $var_num++;
$var_type{$var} = 'array';
splice(@code, $index, 1, &make_op($var, 'rest_args', $var{$var}));
}
foreach $index (@fix_pred_funcs) {
my($name, @ops) = @{$code[$index]};
my(@args);
my $var;
foreach $var (@ops) {
&error($where, "variable '$var' unbound")
unless defined $var{$var};
if ($var_type{$var} eq 'scalar') {
push(@args, "var[$var{$var}]");
} else {
push(@args, "var+$var{$var}");
}
}
splice(@code, $index, 1, &make_op("$name()",
'pred', scalar(@pred_table)));
push(@pred_table, [$name, @args]);
}
$te_max_vars = $var_num
if $te_max_vars < $var_num;
[$min_window, \%var, \%var_type, \@code];
}
sub tr_gen_to {
my($line, $orig_transform, $so_far, @tr) = @_;
my($min_window, $var_ref, $var_type_ref, $code_ref) = @$so_far;
my(%var) = %$var_ref;
my(%var_type) = %$var_type_ref;
my(@code) = @$code_ref;
my($op, $ref); # Loop variables.
my($where) = "right side of transformation in line $line: ";
foreach $ref (@tr) {
my($name, $arity, @ops) = @$ref;
#
# A name starting with a period is a C function to be called.
#
if ($name =~ /^\.(\w+)/) {
$name = $1;
my $var;
my(@args);
foreach $var (@ops) {
&error($where, "variable '$var' unbound")
unless defined $var{$var};
if ($var_type{$var} eq 'scalar') {
push(@args, "var[$var{$var}]");
} else {
push(@args, "var+$var{$var}");
}
}
pop(@code); # Get rid of 'next_instr'
push(@code, &make_op("$name()", 'call', scalar(@call_table)));
push(@call_table, [$name, @args]);
last;
}
#
# Check that $name/$arity refers to a valid generic instruction.
#
my($key) = "$name/$arity";
&error($where, "invalid generic op $name/$arity")
unless defined $gen_opnum{$name,$arity};
my $opnum = $gen_opnum{$name,$arity};
#
# Create code to build the generic instruction.
#
push(@code, &make_op('', 'new_instr'));
push(@code, &make_op("$name/$arity", 'store_op', $opnum, $arity));
foreach $op (@ops) {
my($var, $type, $type_val) = @$op;
if ($var ne '') {
&error($where, "variable '$var' unbound")
unless defined $var{$var};
push(@code, &make_op($var, 'store_var', $var{$var}));
} elsif ($type ne '') {
push(@code, &make_op('', 'store_type', "TAG_$type"));
if ($type_val) {
push(@code, &make_op('', 'store_val', $type_val));
}
}
push(@code, &make_op('', 'next_arg'));
}
pop(@code) if $code[$#code]->[1][0] eq 'next_arg';
}
push(@code, &make_op('', 'end'));
#
# 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;
my($ref);
foreach $ref (@_) {
$sum += $$ref[0];
}
$sum;
}
sub make_op {
my($comment, @op) = @_;
[scalar(@op), [@op], $comment];
}
sub is_set_var_instr {
my($ref) = @_;
return 0 unless ref($ref) eq 'ARRAY';
$ref->[1][0] eq 'set_var';
}
sub tr_gen_call {
my(@call_table) = @_;
my($i);
print "\n";
for ($i = 0; $i < @call_table; $i++) {
my $ref = $call_table[$i];
my($name, @args) = @$ref;
print "case $i: RVAL = $name(", join(', ', 'st', @args), "); break;\n";
}
print "\n";
}
Jump to Line
Something went wrong with that request. Please try again.