aboutsummaryrefslogtreecommitdiffstats
path: root/erts/emulator/utils/beam_makeops
diff options
context:
space:
mode:
Diffstat (limited to 'erts/emulator/utils/beam_makeops')
-rwxr-xr-xerts/emulator/utils/beam_makeops2015
1 files changed, 1485 insertions, 530 deletions
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops
index 0b7c16f606..d7791d23fa 100755
--- a/erts/emulator/utils/beam_makeops
+++ b/erts/emulator/utils/beam_makeops
@@ -2,56 +2,56 @@
#
# %CopyrightBegin%
#
-# Copyright Ericsson AB 1998-2012. All Rights Reserved.
+# Copyright Ericsson AB 1998-2017. 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/.
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
#
-# 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.
+# http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
#
# %CopyrightEnd%
#
use strict;
use vars qw($BEAM_FORMAT_NUMBER);
+use constant COLD => 0;
+use constant WARM => 1;
+use constant HOT => 2;
+
+# Instructions for packing
+use constant PACK_JUMP => 1;
+use constant PACK_IN_INSTR_WORD => 2;
+use constant PACK_OPT_IN_INSTR_WORD => 4;
+
+# Packing commands
+use constant PACK_CMD_TIGHTEST => '1';
+use constant PACK_CMD_TIGHT => '2';
+use constant PACK_CMD_LOOSE => '3';
+use constant PACK_CMD_WIDE => '4';
$BEAM_FORMAT_NUMBER = undef;
my $target = \&emulator_output;
my $outdir = "."; # Directory for output files.
my $verbose = 0;
-my $hot = 1;
+my $hotness = 1;
my $num_file_opcodes = 0;
my $wordsize = 32;
-my %defs; # Defines (from command line).
+my $code_pointers_are_short = 0; # Whether code pointers (to C code) are short.
+my $code_model = 'unknown';
+my %defs; # Defines (from command line).
# 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];
+
+my @basic_pack_options = (0);
+my @extended_pack_options = @basic_pack_options;
# There are two types of instructions: generic and specific.
# The generic instructions are those generated by the Beam compiler.
@@ -77,6 +77,10 @@ my %num_specific;
my %gen_to_spec;
my %specific_op;
+# Information about each specific operator. Key is the print name (e.g. get_list_xxy).
+# Value is a hash.
+my %spec_op_info;
+
my %gen_arity;
my @gen_arity;
@@ -85,17 +89,22 @@ my @op_to_name;
my @obsolete;
-my %macro;
-my %macro_flags;
+# Instructions and micro instructions implemented in C.
+my %c_code; # C code block, location, arguments.
+my %c_code_used; # Used or not.
-my %hot_code;
-my %cold_code;
+# Definitions for instructions combined from micro instructions.
+my %combined_instrs;
+
+my @generated_code; # Generated code.
+my %sort_order;
my @unnumbered_generic;
my %unnumbered;
my %is_transformed;
+
#
# Pre-processor.
#
@@ -107,7 +116,6 @@ my @if_line;
#
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;
@@ -133,13 +141,15 @@ my %arg_size = ('r' => 0, # x(0) - x register zero
'n' => 0, # NIL (implicit)
'c' => 1, # tagged constant (integer, atom, nil)
's' => 1, # tagged source; any of the above
+ 'S' => 1, # tagged source register (x or y)
'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
+ 't' => 1, # untagged integer (12 bits) -- can be packed
+ 'I' => 1, # untagged integer (32 bits) -- can be packed
+ 'W' => 1, # untagged integer/pointer (one word)
'b' => 1, # pointer to bif
'A' => 1, # arity value
'P' => 1, # byte offset into tuple or stack
@@ -175,21 +185,22 @@ sub define_type_bit {
}
# Composed types.
- define_type_bit('d', $type_bit{'x'} | $type_bit{'y'} | $type_bit{'r'});
+ define_type_bit('d', $type_bit{'x'} | $type_bit{'y'});
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'});
+ $type_bit{'a'} | $type_bit{'n'} |
+ $type_bit{'q'});
+ define_type_bit('S', $type_bit{'d'});
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('I', $type_bit{'u'});
+ define_type_bit('W', $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'});
@@ -216,6 +227,12 @@ $match_engine_ops{'TOP_fail'} = 1;
sanity("tag '$tag': primitive tags must be named with lowercase letters")
unless $tag =~ /^[a-z]$/;
}
+
+ foreach my $tag (keys %arg_size) {
+ defined $type_bit{$tag} or
+ sanity("the tag '$tag' has a size in %arg_size, " .
+ "but has no defined bit pattern");
+ }
}
#
@@ -229,17 +246,69 @@ while (@ARGV && $ARGV[0] =~ /^-(.*)/) {
($target = \&compiler_output), next if /^compiler/;
($outdir = shift), next if /^outdir/;
($wordsize = shift), next if /^wordsize/;
+ ($code_model = shift), next if /^code-model/;
($verbose = 1), next if /^v/;
($defs{$1} = $2), next if /^D(\w+)=(\w+)/;
die "$0: Bad option: -$_\n";
}
+if ($wordsize == 32) {
+ $defs{'ARCH_32'} = 1;
+ $defs{'ARCH_64'} = 0;
+} elsif ($wordsize == 64) {
+ $defs{'ARCH_32'} = 0;
+ $defs{'ARCH_64'} = 1;
+ $code_pointers_are_short = $code_model eq 'small';
+}
+
+#
+# Initialize pack options.
+#
+
+if ($wordsize == 64) {
+ @basic_pack_options = (0,PACK_JUMP);
+ @extended_pack_options = @basic_pack_options;
+ if ($code_pointers_are_short) {
+ foreach (@basic_pack_options) {
+ push @extended_pack_options, $_ | PACK_IN_INSTR_WORD;
+ }
+ }
+}
+
+#
+# Add placeholders for built-in macros.
+#
+
+$c_code{'IS_PACKED'} = ['$Expr',"built-in macro",('Expr')];
+$c_code{'ARG_POSITION'} = ['$Expr',"built-in macro",('Expr')];
+foreach my $name (keys %c_code) {
+ $c_code_used{$name} = 1;
+}
+
#
# Parse the input files.
#
+my $in_c_code = '';
+my $c_code_block;
+my $c_code_loc;
+my @c_args;
+
while (<>) {
my($op_num);
+ if ($in_c_code) {
+ if (/^\}/) {
+ my $name = $in_c_code;
+ my $block = $c_code_block;
+ $in_c_code = '';
+ $block =~ s/^ //mg;
+ chomp $block;
+ $c_code{$name} = [$block,$c_code_loc,@c_args];
+ } else {
+ $c_code_block .= $_;
+ }
+ next;
+ }
chomp;
if (s/\\$//) {
$_ .= <>;
@@ -247,6 +316,7 @@ while (<>) {
}
next if /^\s*$/;
next if /^\#/;
+ next if m@^//@;
#
# Handle %if.
@@ -295,39 +365,50 @@ while (<>) {
}
#
- # Handle %hot/%cold.
+ # Handle %hot, %warm, and %cold.
#
if (/^\%hot/) {
- $hot = 1;
+ $hotness = HOT;
next;
+ } elsif (/^\%warm/) {
+ $hotness = WARM;
+ next;
} elsif (/^\%cold/) {
- $hot = 0;
+ $hotness = COLD;
next;
}
-
+
#
- # Handle macro definitions.
+ # Handle transformations.
#
- 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);
+ if (/=>/) {
+ parse_transformation($_);
next;
}
#
- # Handle transformations.
+ # Handle C code blocks.
#
- if (/=>/) {
- &parse_transformation($_);
- next;
+ if (/^(\w[\w.]*)\(([^\)]*)\)\s*{/) {
+ my $name = $1;
+ $in_c_code = $name;
+ $c_code_block = '';
+ @c_args = parse_c_args($2);
+ $c_code_loc = "$ARGV($.)";
+ if (defined $c_code{$name}) {
+ my $where = $c_code{$name}->[1];
+ error("$name: already defined at $where");
+ }
+ next;
+ }
+
+ #
+ # Handle definition of instructions in terms of
+ # micro instructions.
+ #
+ if (/^(\w+)\s*:=\s*([\w.]+)\s*;\s*$/) {
+ $combined_instrs{$1} = ["$ARGV($.)",$2];
+ next;
}
#
@@ -336,8 +417,8 @@ while (<>) {
$op_num = undef;
if (s/^(\d+):\s*//) {
$op_num = $1;
- $op_num != 0 or &error("Opcode 0 invalid");
- &error("Opcode $op_num already defined")
+ $op_num != 0 or error("Opcode 0 invalid");
+ error("Opcode $op_num already defined")
if defined $gen_opname[$op_num];
}
@@ -348,11 +429,11 @@ while (<>) {
my($obsolete) = $1;
my($name) = $2;
my($arity) = $3;
- $name =~ /^[a-z]/ or &error("Opname must start with a lowercase letter");
+ $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}");
+ 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}");
+ error("Opname $name already defined with arity $gen_arity{$name}");
if (defined $op_num) { # Numbered generic operation
$gen_opname[$op_num] = $name;
@@ -361,7 +442,6 @@ while (<>) {
$gen_arity{$name} = $arity;
$gen_to_spec{"$name/$arity"} = undef;
$num_specific{"$name/$arity"} = 0;
- $min_window{"$name/$arity"} = 255;
$obsolete[$op_num] = defined $obsolete;
} else { # Unnumbered generic operation.
push(@unnumbered_generic, [$name, $arity]);
@@ -374,17 +454,9 @@ while (<>) {
# 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 (defined $gen_opnum{$name,$arity} and $obsolete[$gen_opnum{$name,$arity}]) {
- error("specific instructions may not be specified for obsolete instructions");
- }
- push(@{$specific_op{"$name/$arity"}}, [$name, $hot, @args]);
+ my($name,$arity) = parse_specific_op($_);
if (defined $op_num) {
- &error("specific instructions must not be numbered");
+ error("specific instructions must not be numbered");
} elsif (!defined($gen_arity{$name}) && !defined($unnumbered{$name,$arity})) {
#
# Create an unumbered generic instruction too.
@@ -419,7 +491,6 @@ $num_file_opcodes = @gen_opname;
$gen_arity{$name} = $arity;
$gen_to_spec{"$name/$arity"} = undef;
$num_specific{"$name/$arity"} = 0;
- $min_window{"$name/$arity"} = 255;
}
}
@@ -427,7 +498,19 @@ $num_file_opcodes = @gen_opname;
# Produce output for the chosen target.
#
-&$target;
+&$target();
+
+#
+# Ensure that all C code implementations have been used.
+#
+{
+ my(@unused) = grep(!$c_code_used{$_}, keys %c_code);
+ foreach my $unused (@unused) {
+ my(undef,$where) = @{$c_code{$unused}};
+ warn "$where: $unused is unused\n";
+ }
+ die "\n" if @unused;
+}
#
# Produce output needed by the emulator/loader.
@@ -439,11 +522,41 @@ sub emulator_output {
my $key; # Loop variable.
#
+ # Generate code and meta information for all instructions.
+ #
+ foreach $key (keys %specific_op) {
+ foreach (@{$specific_op{$key}}) {
+ my($name, $hotness, @args) = @$_;
+ my $print_name = print_name($name, @args);
+
+ my($size, $code, $pack_spec) = cg_basic(name => $name, args => \@args);
+ if (defined $code) {
+ $code = "OpCase($print_name):\n$code";
+ push @generated_code, [$hotness,$code,($print_name)];
+ }
+
+ # Note: Some of the information below will be modified
+ # for combined instructions.
+ my %info = ('size' => $size,
+ 'pack_spec' => $pack_spec,
+ 'adj' => 0,
+ 'args' => \@args);
+ $spec_op_info{$print_name} = \%info;
+ }
+ }
+
+ #
+ # Combine micro instruction into instruction blocks and generate
+ # code for them.
+ #
+ combine_micro_instructions();
+
+ #
# Information about opcodes (beam_opcodes.c).
#
$name = "$outdir/beam_opcodes.c";
open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
- &comment('C');
+ comment('C');
print "#ifdef HAVE_CONFIG_H\n";
print "# include \"config.h\"\n";
print "#endif\n\n";
@@ -456,7 +569,7 @@ sub emulator_output {
print '#include "beam_load.h"', "\n";
print "\n";
- print "char tag_to_letter[] = {\n ";
+ print "const char tag_to_letter[] = {\n ";
for ($i = 0; $i < length($genop_types); $i++) {
print "'$tag_type[$i]', ";
}
@@ -469,8 +582,8 @@ sub emulator_output {
#
# Generate code for specific ops.
#
- my($spec_opnum) = 0;
- print "OpEntry opc[] = {\n";
+ my $spec_opnum = 0;
+ print "const OpEntry opc[] = {\n";
foreach $key (sort keys %specific_op) {
$gen_to_spec{$key} = $spec_opnum;
$num_specific{$key} = @{$specific_op{$key}};
@@ -484,40 +597,26 @@ sub emulator_output {
foreach (@{$specific_op{$key}}) {
my($name, $hot, @args) = @{$_};
my($sign) = join('', @args);
+ $sign =~ s/[?]//g;
# The primitive types should sort before other types.
- my($sort_key) = $sign;
+ my $sort_key = $sign;
eval "\$sort_key =~ tr/$genop_types/./";
$sort_key .= ":$sign";
- $items{$sort_key} = [$name, $hot, $sign, @args];
+ my $print_name = print_name($name, @args);
+ $items{$sort_key} = $print_name;
}
#
# Now call the generator for the sorted result.
#
- foreach (sort keys %items) {
- my($name, $hot, $sign, @args) = @{$items{$_}};
+ foreach my $sort_key (sort keys %items) {
+ my $print_name = $items{$sort_key};
+ my $info = $spec_op_info{$print_name};
+ my(@args) = @{$info->{'args'}};
+ @args = map { s/[?]$//; $_ } @args;
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
@@ -526,16 +625,19 @@ sub emulator_output {
my(@bits) = (0) x ($max_spec_operands/2);
my($i);
+ my $involves_r = 0;
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;
+ my $bits = $type_bit{$t};
+ if ($t eq 'r') {
+ $bits |= $type_bit{'x'};
+ $involves_r |= 1 << $i;
}
+ my $shift = $max_genop_types * ($i % 2);
+ $bits[int($i/2)] |= $bits << $shift;
}
printf "/* %3d */ ", $spec_opnum;
- my $print_name = $sign ne '' ? "${name}_$sign" : $name;
my $init = "{";
my $sep = "";
foreach (@bits) {
@@ -543,25 +645,38 @@ sub emulator_output {
$sep = ",";
}
$init .= "}";
- &init_item($print_name, $init, $size, $pack, $sign, 0);
- $op_to_name[$spec_opnum] = $instr;
+ my $adj = $info->{'adj'};
+ my $size = $info->{'size'};
+ my $pack_spec = $info->{'pack_spec'};
+ my $sign = join '', @args;
+ init_item($print_name, $init, $involves_r, $size, $adj, $pack_spec, $sign);
+ $op_to_name[$spec_opnum] = $print_name;
$spec_opnum++;
}
}
print "};\n\n";
- print "int num_instructions = $spec_opnum;\n\n";
+ print "const int num_instructions = $spec_opnum;\n\n";
+
+ #
+ # Print the array for instruction counts.
+ #
+
+ print "#ifdef ERTS_OPCODE_COUNTER_SUPPORT\n";
+ print "Uint erts_instr_count[$spec_opnum];\n";
+ print "#endif\n";
+ print "\n";
#
# Generate transformations.
#
- &tr_gen(@transformations);
+ tr_gen(@transformations);
#
# Print the generic instruction table.
#
- print "GenOpEntry gen_opc[] = {\n";
+ print "const 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";
@@ -570,7 +685,7 @@ sub emulator_output {
my($arity) = $gen_arity[$i];
printf "/* %3d */ ", $i;
if (!defined $name) {
- &init_item("", 0, 0, 0, -1);
+ init_item("", 0, 0, 0, -1);
} else {
my($key) = "$name/$arity";
my($tr) = defined $gen_transform_offset{$key} ?
@@ -582,7 +697,7 @@ sub emulator_output {
$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});
+ init_item($name, $arity, $spec_op, $num_specific, $tr);
}
}
print "};\n";
@@ -592,7 +707,7 @@ sub emulator_output {
#
$name = "$outdir/beam_opcodes.h";
open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
- &comment('C');
+ comment('C');
print "#ifndef __OPCODES_H__\n";
print "#define __OPCODES_H__\n\n";
@@ -600,24 +715,34 @@ sub emulator_output {
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 "#define SCRATCH_X_REG 1023\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";
+ if ($wordsize == 32) {
+ print "#if defined(ARCH_64)\n";
+ print qq[ #error "32-bit architecture assumed, but ARCH_64 is defined"\n];
+ print "#endif\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";
+ } elsif ($wordsize == 64) {
+ print "#if !defined(ARCH_64)\n";
+ print qq[ #error "64-bit architecture assumed, but ARCH_64 not defined"\n];
+ print "#endif\n";
+ if ($code_pointers_are_short) {
+ print "#if !defined(CODE_MODEL_SMALL)\n";
+ print qq[ #error "small code model assumed, but CODE_MODEL_SMALL not defined"\n];
+ print "#endif\n";
+ }
+ print "#define BEAM_WIDE_MASK 0xFFFFFFFFull\n";
+ print "#define BEAM_LOOSE_MASK 0xFFFFull\n";
+ print "#define BEAM_TIGHT_MASK 0xFFFFull\n";
+ print "#define BEAM_TIGHTEST_MASK 0x3FFull\n";
+ print "#define BEAM_WIDE_SHIFT 32\n";
+ print "#define BEAM_LOOSE_SHIFT 16\n";
+ print "#define BEAM_TIGHT_SHIFT 16\n";
+ print "#define BEAM_TIGHTEST_SHIFT 10\n";
+ }
print "\n";
#
@@ -627,14 +752,14 @@ sub emulator_output {
my $letter;
my $tag_num = 0;
- &comment('C', "The following operand types for generic instructions",
+ 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.");
+ 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++;
@@ -652,8 +777,8 @@ sub emulator_output {
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 "extern const char tag_to_letter[];\n";
+ print "extern const Uint op_transform[];\n";
print "\n";
for ($i = 0; $i < @op_to_name; $i++) {
@@ -682,7 +807,7 @@ sub emulator_output {
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 " \\\nCountCase($name): erts_instr_count[$i]++; goto lb_$name;";
}
print "\n\n";
@@ -701,27 +826,38 @@ sub emulator_output {
$name = "$outdir/beam_tr_funcs.h";
open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
- &comment('C');
- &tr_gen_call(@call_table);
+ 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);
+ 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);
+ comment('C');
+ print_code(HOT);
+
+ $name = "$outdir/beam_warm.h";
+ open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
+ comment('C');
+ print_code(WARM);
$name = "$outdir/beam_cold.h";
open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
- &comment('C');
- &print_code(\%cold_code);
+ comment('C');
+ print_code(COLD);
+}
+sub print_name {
+ my($name,@args) = @_;
+ my $sign = join '', @args;
+ $sign =~ s/[?]//g;
+ $sign ne '' ? "${name}_$sign" : $name;
}
sub init_item {
@@ -733,7 +869,7 @@ sub init_item {
print "${sep}NULL";
} elsif (/^\{/) {
print "$sep$_";
- } elsif (/^-?\d/) {
+ } elsif (/^-?\d+$/) {
print "$sep$_";
} else {
print "$sep\"$_\"";
@@ -749,29 +885,47 @@ sub q {
}
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;
+ my($include_hot) = @_;
+ my %sorted;
+
+ foreach my $ref (@generated_code) {
+ my($hot,$code,@labels) = @$ref;
+ next unless $hot == $include_hot;
+ my($sort_key) = @labels; # Use the first label as sort key.
+ $sorted{$sort_key} = $code;
}
foreach (sort keys %sorted) {
- print $sorted{$_};
+ print_indented_code($sorted{$_});
}
}
+sub print_indented_code {
+ my(@code) = @_;
+
+ foreach my $chunk (@code) {
+ my $indent = 0;
+ foreach (split "\n", $chunk) {
+ s/^\s*//;
+ if (/\}/) {
+ $indent -= 2;
+ }
+ if ($_ eq '') {
+ print "\n";
+ } elsif (/^#/) {
+ print $_, "\n";
+ } else {
+ print ' ' x $indent, $_, "\n";
+ }
+ if (/\{/) {
+ $indent += 2;
+ }
+ }
+ print "\n";
+ }
+}
+
+
#
# Produce output needed by the compiler back-end (assembler).
#
@@ -783,7 +937,7 @@ sub compiler_output {
open(STDOUT, ">$outdir/$name") || die "Failed to open $name for writing: $!\n";
print "-module($module).\n";
- &comment('erlang');
+ comment('erlang');
print "-export([format_number/0]).\n";
print "-export([opcode/2,opname/1]).\n";
@@ -795,7 +949,7 @@ sub compiler_output {
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(", quote($gen_opname[$i]), ", $gen_arity[$i]) -> $i;\n";
}
print "opcode(Name, Arity) -> erlang:error(badarg, [Name,Arity]).\n\n";
@@ -803,7 +957,7 @@ sub compiler_output {
for ($i = 0; $i < @gen_opname; $i++) {
next unless defined $gen_opname[$i];
print "opname($i) -> {",
- &quote($gen_opname[$i]), ",$gen_arity[$i]};\n";
+ quote($gen_opname[$i]), ",$gen_arity[$i]};\n";
}
print "opname(Number) -> erlang:error(badarg, [Number]).\n";
@@ -812,7 +966,7 @@ sub compiler_output {
#
my($hrl_name) = "$outdir/${module}.hrl";
open(STDOUT, ">$hrl_name") || die "Failed to open $hrl_name for writing: $!\n";
- &comment('erlang');
+ comment('erlang');
for ($i = 0; $i < @tag_type && $i < 8; $i++) {
print "-define(tag_$tag_type[$i], $i).\n";
@@ -822,18 +976,66 @@ sub compiler_output {
}
#
-# Check an operation for validity.
+# Parse and store a specific operation.
#
-sub syntax_check {
- my($name, @args) = @_;
- my($i);
+sub parse_specific_op {
+ my($name, @args) = split " ", shift;
+ my $arity = @args;
- &error("Bad opcode name '$name'")
+ # Check for various errors.
+ 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]};
+ error("too many operands")
+ if @args > $max_spec_operands;
+ for (my $i = 0; $i < $arity; $i++) {
+ my $arg = $args[$i];
+ $arg =~ s/[?]$//;
+ foreach my $type (split(//, $arg)) {
+ error("Argument " . ($i+1) . ": invalid type '$type'")
+ unless defined $arg_size{$type};
+ }
+ }
+ if (defined $gen_opnum{$name,$arity} and $obsolete[$gen_opnum{$name,$arity}]) {
+ error("specific instructions may not be specified for obsolete instructions");
+ }
+
+ # Expand operands with multiple types to multiple instructions.
+ # (For example, "get_list xy xy xy" will be expanded to six instructions.)
+ my @res = ([]);
+ foreach my $arg (@args) {
+ my @old_res = @res;
+ @res = ();
+ my $marker = ($arg =~ s/[?]$//) ? '?' : '';
+ foreach my $type (split(//, $arg)) {
+ foreach my $args_ref (@old_res) {
+ my @args = @$args_ref;
+ push @args, "$type$marker";
+ push @res, \@args;
+ }
+ }
+ }
+
+ # Store each specific instruction.
+ my $key = "$name/$arity";
+ foreach my $args_ref (@res) {
+ @args = @$args_ref;
+ push @{$specific_op{$key}}, [$name,$hotness,@args];
+ }
+
+ # Done.
+ ($name,$arity);
+}
+
+sub parse_c_args {
+ local($_) = @_;
+ my @res;
+
+ while (s/^(\w[\w\d]*)\s*//) {
+ push @res, $1;
+ s/^,\s*// or last;
}
+ $_ eq '' or error("garbage in argument list: $_");
+ @res;
}
sub error {
@@ -877,58 +1079,311 @@ sub comment {
}
#
-# Basic implementation of instruction in emulator loop
-# (assuming no packing).
+# Combine micro instruction into instruction blocks.
#
+sub combine_micro_instructions {
+ my %groups;
+
+ # Sanity check, normalize micro instructions.
+ foreach my $instr (keys %combined_instrs) {
+ my $ref = $combined_instrs{$instr};
+ my($def_loc,$def) = @$ref;
+ my($group,@subs) = split /[.]/, $def;
+ my $arity = 0;
+ @subs = map { "$group.$_" } @subs;
+ foreach my $s (@subs) {
+ my $code = $c_code{$s};
+ defined $code or
+ error("$def_loc: no definition of $s");
+ $c_code_used{$s} = 1;
+ my(undef,undef,@c_args) = @{$code};
+ $arity += scalar(@c_args);
+ }
+ push @{$groups{$group}}, [$instr,$arity,@subs];
+ }
+
+ # Now generate code for each group.
+ foreach my $group (sort keys %groups) {
+ my($hotness,$code,@labels) =
+ combine_instruction_group($group, @{$groups{$group}});
+ push @generated_code, [$hotness,$code,@labels];
+ }
+}
-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);
+sub combine_instruction_group {
+ my($group,@in_instrs) = @_;
+ my $gcode = ''; # Code for the entire group.
+ my $group_hotness = COLD;
- # 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,
- );
+ # Get code for the head of the group (if any).
+ my $head_name = "$group.head";
+ $c_code_used{$head_name} = 1;
+ my $head_code_ref = $c_code{$head_name};
+ if (defined $head_code_ref) {
+ my($head_code,$where,@c_args) = @{$head_code_ref};
+ @c_args and error("$where: no arguments allowed for " .
+ "head function '$head_name()'");
+ $gcode = $head_code . "\n";
+ }
- # Pick up the macro to use and its flags (if any).
+ # Variables.
+ my %offsets;
+ my @instrs;
+ my %num_references; # Number of references from other sub instructions.
+ my $group_size = 999;
- $macro = $macro{$name} if defined $macro{$name};
- $flags = $macro_flags{$name} if defined $macro_flags{$name};
+ #
+ # Calculate the number of references from other sub instructions.
+ # This number is useful in several ways:
+ #
+ # * If this number is 0, it is only used as the entry point for a
+ # function, implying that it does not need a label and that operands
+ # can be packed into the instruction word.
+ #
+ # * We'll use this number in the sort key, as a tie breaker for sub instructions
+ # at the same instruction offset.
+ #
+ foreach my $ref_instr (@in_instrs) {
+ my(undef,undef,$first_sub,@other_subs) = @$ref_instr;
+ $num_references{$first_sub} += 0; # Make sure it is defined.
+ foreach my $sub (@other_subs) {
+ $num_references{$sub}++;
+ }
+ }
+
+ # Do basic error checking. Associate operands of instructions
+ # with the correct micro instructions. Calculate offsets for micro
+ # instructions.
+ foreach my $ref_instr (@in_instrs) {
+ my($specific,$arity,@subs) = @$ref_instr;
+ my $specific_key = "$specific/$arity";
+ my $specific_op_ref = $specific_op{$specific_key};
+ error("no $specific_key instruction")
+ unless defined $specific_op_ref;
+ foreach my $specific_op (@$specific_op_ref) {
+ my($name, $hotness, @args) = @{$specific_op};
+ $group_hotness = $hotness unless $group_hotness >= $hotness;
+ my $offset = 0;
+ my @rest = @args;
+ my @new_subs;
+ my $print_name = print_name($specific, @args);
+ my $opcase = $print_name;
+ my $last = $subs[$#subs];
+ foreach my $s (@subs) {
+ my $code = $c_code{$s};
+ my(undef,undef,@c_args) = @{$code};
+ my @first;
+ foreach (0..$#c_args) {
+ push @first, shift @rest;
+ }
+ my $size = cg_combined_size(name => $s,
+ first => $num_references{$s} == 0,
+ args => \@first);
+ $offsets{$s} = $offset
+ unless defined $offsets{$s} and $offsets{$s} < $offset;
+ $offset += $size - 1;
+ my $label = micro_label($s);
+ push @new_subs, [$opcase,$label,$s,$size-1,@first];
+ $opcase = '';
+ }
+ $spec_op_info{$print_name}->{'size'} = $offset + 1;
+ $group_size = $offset if $group_size >= $offset;
+ push @instrs, [$specific_key,@new_subs];
+ }
+ }
+
+ # Link the sub instructions for each instructions to each
+ # other.
+ my @all_instrs;
+ foreach my $instr (@instrs) {
+ my($specific_key,@subs) = @{$instr};
+ for (my $i = 0; $i < @subs; $i++) {
+ my($opcase,$label,$s,$size,@args) = @{$subs[$i]};
+ my $next = '';
+ (undef,$next) = @{$subs[$i+1]} if $i < $#subs;
+ my $instr_info = "$opcase:$label:$next:$s:$size:@args";
+ push @all_instrs, [$label,$s,$offsets{$s},$instr_info];
+ }
+ }
+
+ my %order_to_instrs;
+ my %label_to_offset;
+ my %order_to_offset;
+ foreach my $instr (@all_instrs) {
+ my($label,$s,$offset,$instr_info) = @$instr;
+ my $sort_key = sprintf("%02d.%02d", $offset, $num_references{$s});
+ push @{$order_to_instrs{$sort_key}}, $instr_info;
+ $label_to_offset{$label} = $offset;
+ $order_to_offset{$sort_key} = $offset;
+ }
+
+ my(@slots) = sort {$a <=> $b} keys %order_to_instrs;
+
+ # Now generate the code for the entire group.
+ my $offset = 0;
+ my @opcase_labels;
+ my %down;
+ my %up;
+ for(my $i = 0; $i < @slots; $i++) {
+ my $key = $slots[$i];
+
+ # Sort micro-instructions with OpCase before other micro-instructions.
+ my(@instrs) = @{$order_to_instrs{$key}};
+ my $order_func = sub {
+ my $a_key = ($a =~ /^:/) ? "1$a" : "0$a";
+ my $b_key = ($b =~ /^:/) ? "1$b" : "0$b";
+ $a_key cmp $b_key;
+ };
+ @instrs = sort $order_func @instrs;
+
+ my %seen;
+ foreach my $instr (@instrs) {
+ my($opcase,$label,$next,$s,$size,$args) = split ":", $instr;
+ my(@first) = split " ", $args;
+
+ my $seen_key = "$label:$next:" . scalar(@first);
+ next if $opcase eq '' and $seen{$seen_key};
+ $seen{$seen_key} = 1;
+ $seen_key .= $opcase;
+
+ if ($opcase ne '') {
+ $gcode .= "OpCase($opcase):\n";
+ push @opcase_labels, $opcase;
+ }
+ if ($num_references{$s}) {
+ $gcode .= "$label:\n";
+ }
+
+ my $flags = '';
+ my $transfer_to_next = '';
+ my $inc = 0;
+
+ unless ($i == $#slots) {
+ $flags = "-no_next";
+ my $next_offset = $label_to_offset{$next};
+ $inc = ($offset + $size) - $next_offset;
+ $transfer_to_next = "I += $inc;\n" if $inc;
+ $transfer_to_next .= "goto $next;\n\n";
+ }
+
+ my($gen_code,$down,$up) =
+ cg_combined_code(name => $s,
+ first => $num_references{$s} == 0,
+ extra_comments => $flags,
+ offset => $offset,
+ comp_size => $group_size-$offset,
+ inc => $inc,
+ args =>\@first);
+ my $spec_label = "$opcase$label";
+ $down{$spec_label} = $down;
+ $up{$spec_label} = $up;
+ $gcode .= $gen_code . $transfer_to_next;
+ }
+ $offset = $order_to_offset{$slots[$i+1]} if $i < $#slots;
+ }
+
+ foreach my $print_name (@opcase_labels) {
+ my $info = $spec_op_info{$print_name};
+ $info->{'adj'} = $info->{'size'} - $group_size - 1;
+ }
#
- # Add any arguments to be included as macro arguments (for instance,
- # 'p' is usually not an argument, except for calls).
+ # Assemble pack specifications for all instructions in the group.
#
+ foreach my $instr (@instrs) {
+ my(undef,@subs) = @{$instr};
+ my $down = '';
+ my $up = '';
+ for (my $i = 0; $i < @subs; $i++) {
+ my($opcase,$label) = @{$subs[$i]};
+ my $spec_label = "$opcase$label";
+ if (defined $down{$spec_label}) {
+ $down = $down{$spec_label} . $down;
+ $up = $up . $up{$spec_label};
+ }
+ }
+ my $print_name = $subs[0]->[0];
+ my $info = $spec_op_info{$print_name};
+ $info->{'pack_spec'} = build_pack_spec("$down:$up");
+ }
+
+ ($group_hotness,"{\n$gcode\n}\n\n",@opcase_labels);
+}
+
+sub micro_label {
+ my $label = shift;
+ $label =~ s/[.]/__/g;
+ $label;
+}
- while ($flags =~ /-arg_(\w)/g) {
- $incl_arg{$1} = 1;
- };
+
+#
+# Basic code generation for one instruction.
+#
+
+sub cg_basic {
+ my %params = (@_, pack_options => \@extended_pack_options);
+ my($size,$code,$pack_spec) = code_gen(%params);
+ $pack_spec = build_pack_spec($pack_spec);
+ ($size,$code,$pack_spec);
+}
+
+#
+# Calculate size for a micro instruction.
+#
+
+sub cg_combined_size {
+ my %params = (@_, pack_options => \@basic_pack_options);
+ $params{pack_options} = \@extended_pack_options
+ if $params{first};
+ my($size) = code_gen(%params);
+ $size;
+}
+
+#
+# Generate code for a micro instruction.
+#
+
+sub cg_combined_code {
+ my %params = (@_, pack_options => \@basic_pack_options);
+ $params{pack_options} = \@extended_pack_options
+ if $params{first};
+ my($size,$code,$pack_spec) = code_gen(%params);
+ if ($pack_spec eq '') {
+ ($code,'','');
+ } else {
+ my($down,$up) = split /:/, $pack_spec;
+ ($code,$down,$up);
+ }
+}
+
+sub code_gen {
+ my %params = (extra_comments => '',
+ offset => 0,
+ inc => 0,
+ @_);
+ my $name = $params{name};
+ my $extra_comments = $params{extra_comments};
+ my $offset = $params{offset};
+ my $inc = $params{inc};
+ my @args = @{$params{args}};
+
+ my $size = 0;
+ my $flags = '';
+ my @f;
+ my $prefix = '';
+ my $tmp_arg_num = 1;
+ my $pack_spec = '';
+ my $var_decls = '';
#
- # Pack arguments if requested.
+ # Pack arguments for hot code with an implementation.
#
- if ($flags =~ /-pack/ && $hot) {
- ($prefix, $pack_spec, @args) = &do_pack(@args);
+ my $c_code_ref = $c_code{$name};
+ if (defined $c_code_ref and $name ne 'catch') {
+ my $pack_options = $params{pack_options};
+ ($var_decls, $pack_spec, @args) = do_pack($name, $offset, $pack_options, @args);
}
#
@@ -936,254 +1391,657 @@ sub basic_generator {
# the macro.
#
+ my $need_block = 0;
+ my $arg_offset = $offset;
+ @args = map { s/[?]$//g; $_ } @args;
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; };
+ /^packed:d:(\d):(.*)/ and do {
+ $var_decls .= "Eterm dst = $2;\n" .
+ "Eterm* dst_ptr = REG_TARGET_PTR(dst);\n";
+ push(@f, "*dst_ptr");
+ $this_size = $1;
+ last SWITCH;
+ };
+ /^packed:[a-zA-z]:(\d):(.*)/ and do {
+ push(@f, $2);
+ $this_size = $1;
+ last SWITCH;
+ };
+ /r/ and do {
+ push(@f, "r(0)");
+ last SWITCH;
+ };
+ /[lxyS]/ and do {
+ push(@f, $_ . "b(" . arg_offset($arg_offset) . ")");
+ last SWITCH;
+ };
+ /n/ and do {
+ push(@f, "NIL");
+ last SWITCH;
+ };
+ /s/ and do {
+ my($tmp) = "targ$tmp_arg_num";
+ $var_decls .= "Eterm $tmp;\n";
+ $tmp_arg_num++;
+ push(@f, $tmp);
+ $prefix .= "GetR($arg_offset, $tmp);\n";
+ $need_block = 1;
+ last SWITCH;
+ };
+ /d/ and do {
+ $var_decls .= "Eterm dst = " . arg_offset($arg_offset) . ";\n" .
+ "Eterm* dst_ptr = REG_TARGET_PTR(dst);\n";
+ push(@f, "*dst_ptr");
+ last SWITCH;
+ };
+ defined $arg_size{$_} and do {
+ push @f, arg_offset($arg_offset);
+ last SWITCH;
+ };
die "$name: The generator can't handle $_, at";
}
$size += $this_size;
+ $arg_offset += $this_size;
}
#
- # If requested, pass a pointer to the destination register.
- # The destination must be the last operand.
+ # If the implementation is in beam_emu.c, there is nothing
+ # more to do.
#
- if ($flags =~ /-gen_dest/) {
- push(@f, $gen_dest_arg);
+ unless (defined $c_code_ref) {
+ return ($size+1, undef, '');
}
+ my $group_size = ($params{comp_size} || $size) + $inc;
+
#
- # Add a fail action macro if requested.
+ # Generate main body of the implementation.
#
+ my($c_code,$where,@c_args) = @{$c_code_ref};
+ my %bindings;
+ $c_code_used{$name} = 1;
- $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 };
- }
- }
- };
+ if (@f != @c_args) {
+ error("$where: defining '$name' with ", scalar(@c_args),
+ " arguments instead of expected ", scalar(@f), " arguments");
+ }
+
+ for (my $i = 0; $i < @f; $i++) {
+ my $var = $c_args[$i];
+ $bindings{$var} = $f[$i];
+ }
+ $bindings{'NEXT_INSTRUCTION'} = "I+" . ($group_size+$offset+1);
+ $bindings{'IP_ADJUSTMENT'} = $inc;
+ $c_code = eval { expand_all($c_code, \%bindings) };
+ unless (defined $c_code) {
+ warn $@;
+ error("... from the body of $name at $where");
+ }
+ my(@comments) = $c_code =~ m@//[|]\s*(.*)@g;
+ $c_code =~ s@//[|]\s*(.*)\n?@@g;
+ $flags = "@comments $extra_comments";
#
- # Add a size argument if requested.
+ # Generate code for transferring to the next instruction.
#
+ my $dispatch_next;
+ my $instr_offset = $group_size + $offset + 1;
+
+ if ($flags =~ /-no_next/) {
+ $dispatch_next = "";
+ } elsif ($flags =~ /-no_prefetch/) {
+ $dispatch_next = "\nI += $instr_offset;\n" .
+ "ASSERT(VALID_INSTR(*I));\n" .
+ "Goto(*I);";
+ } else {
+ $var_decls .= "BeamInstr next_pf = BeamCodeAddr(I[$instr_offset]);\n";
+ $dispatch_next = "\nI += $instr_offset;\n" .
+ "ASSERT(VALID_INSTR(next_pf));\n" .
+ "GotoPF(next_pf);";
+ }
- $flags =~ /-size/ and do {
- push(@f, $size);
- };
+ #
+ # Assemble the complete code for the instruction.
+ #
+ my $body = "$c_code$dispatch_next";
+ if ($need_block) {
+ $body = "$prefix\{\n$body\n}";
+ } else {
+ $body = "$prefix$body";
+ }
+ my $code = join("\n",
+ "{",
+ "$var_decls$body",
+ "}", "");
+ ($size+1, $code, $pack_spec);
+}
- # 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);",
- "}", "");
- }
+sub arg_offset {
+ my $offset = shift;
+ "I[" . ($offset+1) . "]";
+}
+
+sub expand_all {
+ my($code,$bindings_ref) = @_;
+ my %bindings = %{$bindings_ref};
+
+ # Expand all $Var occurrences.
+ $code =~ s/[\$](\w[\w\d]*)(?!\()/defined $bindings{$1} ? $bindings{$1} : "\$$1"/ge;
+
+ # Find calls to macros, $name(...), and expand them.
+ my $res = "";
+ while ($code =~ /[\$](\w[\w\d]*)\(/) {
+ my $macro_name = $1;
+ my $keep = substr($code, 0, $-[0]);
+ my $after = substr($code, $+[0]);
+
+ my $body;
+ ($body,$code) = expand_macro($macro_name, $after, \%bindings);
+ $res .= "$keep$body";
}
- # Return the size and code for the macro (if any).
- $size++;
- ($size, $code, $pack_spec);
+ $res . $code;
+}
+
+sub expand_macro {
+ my($name,$rest,$bindings_ref) = @_;
+
+ my $c_code = $c_code{$name};
+ defined $c_code or
+ error("calling undefined macro '$name'...");
+ $c_code_used{$name} = 1;
+ my ($body,$where,@vars) = @{$c_code};
+
+ # Separate the arguments into @args;
+ my @args;
+ my $level = 1;
+ my %inc = ('(' => 1, ')' => -1,
+ '[' => 1, ']' => -1,
+ '{' => 1, '}' => -1);
+ my $arg = undef;
+ while ($rest =~ /([,\(\[\{\}\]\)]|([^,\(\[\{\}\]\)]*))/g) {
+ my $token = $1;
+ my $inc = $inc{$token} || 0;
+ $level += $inc;
+ if ($level == 0) {
+ $rest = substr($rest, pos($rest));
+ push @args, $arg if defined $arg;
+ last;
+ }
+ if ($token eq ',') {
+ if ($level == 1) {
+ push @args, $arg;
+ $arg = "";
+ }
+ next;
+ }
+ $arg .= $token;
+ }
+
+ # Trim leading whitespace from each argument.
+ foreach my $arg (@args) {
+ $arg =~ s/^\s*//;
+ }
+
+ # Make sure that the number of arguments are correct.
+ if (@vars != @args) {
+ error("calling $name with ", scalar(@args),
+ " arguments instead of expected ", scalar(@vars), " arguments...");
+ }
+
+ # Now combine bindings from the parameter names and arguments.
+ my %bindings = %{$bindings_ref};
+ my %new_bindings;
+
+ # Keep the special, pre-defined bindings.
+ foreach my $key (qw(NEXT_INSTRUCTION IP_ADJUSTMENT)) {
+ $new_bindings{$key} = $bindings{$key};
+ }
+
+ for (my $i = 0; $i < @vars; $i++) {
+ my $arg = $args[$i];
+ $arg = eval { expand_all($arg, \%bindings) };
+ unless (defined $arg) {
+ warn $@;
+ die "... from the body of $name at $where\n";
+ }
+ $new_bindings{$vars[$i]} = $arg;
+ }
+
+ $body = eval { expand_all($body, \%new_bindings) };
+ unless (defined $body) {
+ warn $@;
+ die "... from the body of $name at $where\n";
+ }
+
+ # Handle built-in macros.
+ if ($name eq 'ARG_POSITION') {
+ if ($body =~ /^I\[(\d+)\]$/) {
+ $body = $1;
+ } else {
+ $body = 0;
+ }
+ } elsif ($name eq 'IS_PACKED') {
+ $body = ($body =~ /^I\[\d+\]$/) ? 0 : 1;
+ }
+
+ # Wrap body if needed and return resul.t
+ $body = "do {\n$body\n} while (0)"
+ if needs_do_wrapper($body);
+ ($body,$rest);
+}
+
+# Conservative heuristic to determine whether a do { ... } while(0)
+# wrapper is needed.
+sub needs_do_wrapper {
+ local $_ = shift;
+
+ s@^//[|][^\n]*\n@@;
+ s@^\s*@@s;
+ s@^/[*].*[*]/\s*@@s;
+ return 1 if /^(Eterm|Uint|Sint|int|unsigned)/; # Definitely needed.
+ return 0 if /^do/;
+ return 0 if /^SET_I/;
+ return 0 if /^SET_CP/;
+ return 0 if /^ERTS_NO_FPE_CHECK_INIT/;
+ return 0 if /^ASSERT/;
+ return 0 if /^DTRACE/;
+ return 0 if /^[A-Za-z_]*\s*=/;
+ return 0 if /^c_p->/;
+ return 0 if /^[A-Z_]*SWAPOUT/;
+ return 0 if /^if\s*[(]/;
+ return 0 if /^goto\b/;
+ return 0 if /^\d+/;
+ return 1; # Not sure, say that it is needed.
}
sub do_pack {
- my(@args) = @_;
+ my($name,$offset,$pack_opts_ref,@args) = @_;
+ my @pack_opts = @$pack_opts_ref;
+ my $opt_arg_pos = -1;
+
+ # Look for an optional use operand not as the first argument.
+ if (@args and $args[0] !~ /[?]$/) {
+ for (my $pos = 0; $pos < @args; $pos++) {
+ if ($args[$pos] =~ /[?]$/) {
+ $opt_arg_pos = $pos;
+ last;
+ }
+ }
+ }
+
+ @args = map { s/[?]$//; $_ } @args; # Remove any optional use marker.
+
+ # If there is an optional operand, extend the array of pack options.
+ if ($opt_arg_pos >= 0) {
+ my @new_pack_opts = grep { $_ & PACK_IN_INSTR_WORD } @pack_opts;
+ @new_pack_opts = map {
+ ($_ & ~ PACK_IN_INSTR_WORD) | PACK_OPT_IN_INSTR_WORD;
+ } @new_pack_opts;
+ push @pack_opts, @new_pack_opts;
+ }
+
+ my $ret = ['', ':', @args];
+ my $score = 0;
+
+ foreach my $options (@pack_opts) {
+ my $this_opt_arg_pos = ($options & PACK_OPT_IN_INSTR_WORD) ? $opt_arg_pos : -1;
+ my($this_score,$this_result) =
+ do_pack_one($name, $options, $this_opt_arg_pos, $offset, @args);
+ if ($this_score > $score) {
+ $ret = $this_result;
+ $score = $this_score;
+ }
+ }
+ return @$ret;
+}
+
+sub do_pack_one {
+ my($name,$options,$opt_arg_pos,$offset,@args) = @_;
my($packable_args) = 0;
- my @is_packable; # Packability (boolean) for each argument.
- my $wide_packing = 0;
+ my @bits_needed; # Bits needed for each argument.
+ my $pack_in_iw = $options & PACK_IN_INSTR_WORD;
+
+ #
+ # Define the minimum number of bits needed for the packable argument types.
+ #
+ my %bits_needed = ('x' => 10,
+ 'y' => 10,
+ 'Q' => 10,
+ 'l' => 10,
+ 'S' => 16,
+ 'd' => 16,
+ 't' => 16);
+ if ($wordsize == 64) {
+ $bits_needed{'I'} = 32;
+ if ($options & PACK_JUMP) {
+ $bits_needed{'f'} = 32;
+ $bits_needed{'j'} = 32;
+ }
+ }
#
- # Count the number of packable arguments. If we encounter any 's' or 'd'
- # arguments, packing is not possible.
+ # Count the number of packable arguments.
#
- my $packable_types = "xytQ";
foreach my $arg (@args) {
- if ($arg =~ /^[$packable_types]/) {
+ if (defined $bits_needed{$arg}) {
$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);
+ push @bits_needed, $bits_needed{$arg};
} else {
- push @is_packable, 0;
+ push @bits_needed, 0;
}
+ if ($arg =~ /^[fj]$/) {
+ # Only pack the first occurrence of 'f' or 'j'.
+ delete $bits_needed{'f'};
+ delete $bits_needed{'j'};
+ }
}
#
- # Get out of here if too few or too many arguments.
+ # Return if there is nothing to pack.
#
- 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;
+ if ($packable_args == 0) {
+ return (-1);
+ } elsif ($packable_args == 1 and $options == 0) {
+ return (-1);
}
- my @shift;
- my @mask;
- my @instr;
+ #
+ # Determine how many arguments we should pack into each word.
+ #
+ my @args_per_word;
+ my @need_wide_mask;
+ my $bits;
+ my $this_wordsize;
+ my $word = -1;
+
+ my $next_word = sub {
+ $word++;
+ $args_per_word[$word] = 0;
+ $need_wide_mask[$word] = 0;
+ $bits = 0;
+ $this_wordsize = $wordsize;
+ };
- 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]};
+ $next_word->();
+ $this_wordsize = 32 if $pack_in_iw;
+ for (my $arg_num = 0; $arg_num < @args; $arg_num++) {
+ my $needed = $bits_needed[$arg_num];
+
+ next unless $needed;
+ next if $arg_num == $opt_arg_pos;
+
+ if ($bits+$needed > $this_wordsize) { # Does not fit.
+ $next_word->();
+ }
+ if ($args_per_word[$word] == 4) { # Can't handle more than 4 args.
+ $next_word->();
+ }
+ if ($needed == 32 and $args_per_word[$word] > 1) {
+ # Must only pack two arguments in this word, and there
+ # are already at least two arguments here.
+ $next_word->();
+ }
+ $args_per_word[$word]++;
+ $bits += $needed;
+ if ($needed == 32) {
+ $need_wide_mask[$word]++;
+ }
+ if ($need_wide_mask[$word] and $bits > 32) {
+ # Can only pack two things in a word where one
+ # item is 32 bits. Force the next item into
+ # the next word.
+ $bits = $this_wordsize;
+ }
}
#
+ # Try to balance packing between words.
+ #
+ if (@args_per_word == 1 and $args_per_word[0] == 1 and $pack_in_iw) {
+ # Don't rebalance.
+ } elsif ($args_per_word[$#args_per_word] == 1) {
+ if ($args_per_word[$#args_per_word-1] < 3) {
+ pop @args_per_word;
+ } else {
+ $args_per_word[$#args_per_word-1]--;
+ $args_per_word[$#args_per_word]++;
+ }
+ } elsif (@args_per_word == 2 and
+ $args_per_word[0] == 4 and
+ $args_per_word[1] == 2) {
+ $args_per_word[0] = 3;
+ $args_per_word[1] = 3;
+ } elsif (@args_per_word == 2 and
+ $args_per_word[0] == 3 and
+ $args_per_word[1] == 1) {
+ $args_per_word[0] = 2;
+ $args_per_word[1] = 2;
+ }
+
+ my $size = 0;
+ my $pack_prefix = '';
+ my $down = ''; # Pack commands (towards instruction
+ # beginning).
+ my $up = ''; # Pack commands (storing back while
+ # moving forward).
+ my $arg_num = 0; # Number of argument.
+
+ # Skip an unpackable argument. Also handle packing of
+ # an single operand into the instruction word.
+ my $skip_unpackable = sub {
+ my($arg) = @_;
+
+ if ($arg_num == $opt_arg_pos) {
+ my $pack = chr(ord('#') + $arg_num);
+ $down = PACK_CMD_WIDE . "$pack$down";
+ my $unpack = "BeamExtraData(I[0])";
+ $args[$arg_num] = "packed:$arg:0:${arg}b($unpack)";
+ } elsif ($arg_size{$arg}) {
+ # Save the argument on the pack engine's stack.
+ my $push = 'g';
+ if ($type_bit{$arg} & $type_bit{'q'}) {
+ # The operand may be a literal.
+ $push = 'q';
+ } elsif ($type_bit{$arg} & $type_bit{'f'}) {
+ # The operand may be a failure label.
+ $push = 'f';
+ }
+ $down = "$push${down}";
+ $up = "${up}p";
+ }
+ };
+
+ #
# 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.
+ for (my $word = 0; $word < @args_per_word; $word++) {
+ my $ap = 0; # Argument number within word.
+ my $packed_var = "tmp_packed" . ($word+1);
+ my $args_per_word = $args_per_word[$word];
+ my $pack_word_size = ($pack_in_iw && $word == 0) ? 32 : $wordsize;
+
+ my($shref,$mref,$iref,$unpack_suffix) =
+ get_pack_parameters($name, $args_per_word, $pack_word_size,
+ $need_wide_mask[$word]);
+ my @shift = @$shref;
+ my @mask = @$mref;
+ my @instr = @$iref;
+
+ while ($ap < $args_per_word) {
+ my $reg = $args[$arg_num];
+ my $this_size = $arg_size{$reg};
+
+ if ($bits_needed[$arg_num]) {
+ $this_size = 0;
+
+ if ($ap == 0) {
+ my $packed_data;
+ if ($pack_in_iw and $word == 0) {
+ $packed_data = "BeamExtraData(I[0])";
+ if ($args_per_word == 1) {
+ $packed_var = $packed_data;
+ } else {
+ $pack_prefix .= "Eterm $packed_var = $packed_data;\n";
+ }
+ my $pack = chr(ord('#') + $size);
+ $down = "$pack$down";
+ } else {
+ $packed_data = arg_offset($size + $offset);
+ $pack_prefix .= "Eterm $packed_var = $packed_data;\n";
+ $down = "P$down";
+ $up .= "p";
+ $this_size = 1;
+ }
+ }
+
+ $down = "$instr[$ap]$down";
+ my $unpack = make_unpack($packed_var, $shift[$ap], $mask[$ap]);
+ my $macro = "$reg$unpack_suffix";
+ $args[$arg_num] = "packed:$reg:$this_size:$macro($unpack)";
+
+ $ap++;
+ } else {
+ $skip_unpackable->($reg);
+ }
+ $size += $this_size;
+ $arg_num++;
+ }
+ }
+
#
- # 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;
- }
+ # Skip any unpackable arguments at the end.
+ #
+ while ($arg_num < @args) {
+ my $arg = $args[$arg_num];
+ $skip_unpackable->($arg);
+ $size += $arg_size{$arg};
+ $arg_num++;
+ }
- $down = "$instr[$ap]$down";
- my($unpack) = &make_unpack($tmpnum, $shift[$ap], $mask[$ap]);
- $args[$i] = "pack:$this_size:$reg" . "b($unpack)";
+ my $pack_spec = "$down:$up";
+ my $score = pack_score($options, @args);
- 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).
- #
+ return ($score, [$pack_prefix,$pack_spec,@args]);
+}
- $down = "g${down}";
- $up = "${up}p";
- }
- $size += $this_size;
- }
+sub get_pack_parameters {
+ my($name,$args_per_word,$pack_word_size,$wide_mask) = @_;
+ my(@shift,@mask,@instr);
+ my $unpack_suffix = 'b';
+
+ if ($wide_mask and $args_per_word > 1) {
+ @shift = ('0', 'BEAM_WIDE_SHIFT');
+ @mask = ('BEAM_WIDE_MASK', $WHOLE_WORD);
+ @instr = (PACK_CMD_WIDE) x 2;
+ } elsif ($args_per_word == 1) {
+ @shift = ('0');
+ @mask = ($WHOLE_WORD);
+ @instr = (PACK_CMD_WIDE);
+ } elsif ($args_per_word == 2) {
+ if ($pack_word_size != $wordsize) {
+ # 64-bit word size, pack 32 bits into instruction word.
+ @shift = ('0', 'BEAM_TIGHT_SHIFT');
+ @mask = ('BEAM_TIGHT_MASK', $WHOLE_WORD);
+ @instr = (PACK_CMD_TIGHT) x 2;
+ } else {
+ # 32/64 bit word size
+ @shift = ('0', 'BEAM_LOOSE_SHIFT');
+ @mask = ('BEAM_LOOSE_MASK', $WHOLE_WORD);
+ @instr = (PACK_CMD_LOOSE) x 2;
+ }
+ } elsif ($args_per_word == 3) {
+ if ($pack_word_size != $wordsize) {
+ # 64-bit word size, pack 3 register numbers into instruction word.
+ @shift = ('0', 'BEAM_TIGHTEST_SHIFT', '(2*BEAM_TIGHTEST_SHIFT)');
+ @mask = ('BEAM_TIGHTEST_MASK', 'BEAM_TIGHTEST_MASK', $WHOLE_WORD);
+ @instr = (PACK_CMD_TIGHTEST) x 3;
+ $unpack_suffix = '';
+ } else {
+ # 32/64 bit word size.
+ @shift = ('0', 'BEAM_TIGHT_SHIFT', '(2*BEAM_TIGHT_SHIFT)');
+ if ($wordsize == 32) {
+ @mask = ('BEAM_TIGHT_MASK') x 3;
+ } elsif ($wordsize == 64) {
+ @mask = ('BEAM_TIGHT_MASK', 'BEAM_TIGHT_MASK', $WHOLE_WORD);
+ }
+ @instr = (PACK_CMD_TIGHT) x 3;
+ }
+ } elsif ($args_per_word == 4) {
+ # 64 bit word size only.
+ @shift = ('0',
+ 'BEAM_LOOSE_SHIFT',
+ '(2*BEAM_LOOSE_SHIFT)',
+ '(3*BEAM_LOOSE_SHIFT)');
+ @mask = ('BEAM_LOOSE_MASK', 'BEAM_LOOSE_MASK',
+ 'BEAM_LOOSE_MASK', $WHOLE_WORD);
+ @instr = (PACK_CMD_LOOSE) x 4;
+ }
+
+ unless (@shift) {
+ error("$name: internal packing error: args_per_word=$args_per_word, " .
+ "pack_word_size=$pack_word_size");
+ }
+
+ (\@shift,\@mask,\@instr,$unpack_suffix);
+}
+
+sub pack_score {
+ my($options,@args) = @_;
+ my $size = 0;
- my $pack_spec = $down . $up;
- return ($pack_prefix, $pack_spec, @args);
+ # Calculate the number of words.
+ foreach (@args) {
+ if (/^packed:[^:]*:(\d+)/) {
+ $size += $1;
+ } else {
+ $size += $arg_size{$_}
+ }
+ }
+
+ # Less numbers of words give a higher score; for the same number of
+ # words, using PACK_JUMP or PACK_IN_INSTR_WORD gives a lower score.
+ my $score = 1 + 10*($max_spec_operands - $size);
+ if (($options & PACK_OPT_IN_INSTR_WORD) != 0) {
+ $score += 4;
+ } elsif ($options == PACK_IN_INSTR_WORD) {
+ $score += 0;
+ } elsif ($options == PACK_JUMP) {
+ $score += 1;
+ } elsif ($options == (PACK_JUMP|PACK_IN_INSTR_WORD)) {
+ $score += 2;
+ } elsif ($options == 0) {
+ $score += 3;
+ }
+ $score;
}
sub make_unpack {
- my($tmpnum, $shift, $mask) = @_;
+ my($packed_var, $shift, $mask) = @_;
- my($e) = "tmp_packed$tmpnum";
+ my $e = $packed_var;
$e = "($e>>$shift)" if $shift;
$e .= "&$mask" unless $mask eq $WHOLE_WORD;
$e;
}
+sub build_pack_spec {
+ my $pack_spec = shift;
+ return '' if $pack_spec eq '';
+ my($down,$up) = split /:/, $pack_spec;
+ while ($down =~ /[gfq]$/ and $up =~ /^p/) {
+ $down = substr($down, 0, -1);
+ $up = substr($up, 1);
+ }
+ "$down$up";
+}
+
sub quote {
local($_) = @_;
return "'$_'" if $_ eq 'try';
@@ -1210,7 +2068,7 @@ sub parse_transformation {
foreach (@from) {
if (/^(\w+)\((.*?)\)/) {
my($name, $arglist) = ($1, $2);
- $_ = (&compile_transform_function($name, split(/\s*,\s*/, $arglist)));
+ $_ = (compile_transform_function($name, split(/\s*,\s*/, $arglist)));
} else {
(@op) = split;
($rest_var,$_) = compile_transform(1, $rest_var, @op);
@@ -1224,9 +2082,12 @@ sub parse_transformation {
#
my @to;
- if ($to =~ /^(\w+)\((.*?)\)/) {
- my($name, $arglist) = ($1, $2);
- @to = (&compile_transform_function($name, split(/\s*,\s*/, $arglist)));
+ if ($to =~ /^(\w+)\((.*?)\)(.*)/) {
+ my($name, $arglist, $garbage) = ($1, $2, $3);
+ if ($garbage =~ /\S/) {
+ error("garbage after call to '$name()'");
+ }
+ @to = (compile_transform_function($name, split(/\s*,\s*/, $arglist)));
} else {
@to = split(/\s*\|\s*/, $to);
foreach (@to) {
@@ -1248,7 +2109,7 @@ sub compile_transform {
my $arity = 0;
foreach (@ops) {
- my(@list) = &tr_parse_op($src, $_);
+ my(@list) = tr_parse_op($src, $_);
if ($list[1] eq '*') {
$rest_var = $list[0];
} elsif (defined $rest_var and $list[0] eq $rest_var) {
@@ -1285,7 +2146,7 @@ sub tr_parse_op {
if (/^([A-Z]\w*)(.*)/) {
$var = $1;
$_ = $2;
- &error("garbage after variable")
+ error("garbage after variable")
unless /^=(.*)/ or /^(\s*)$/;
$_ = $1;
}
@@ -1296,8 +2157,10 @@ sub tr_parse_op {
$type = $1;
$_ = $2;
foreach (split('', $type)) {
- &error("bad type in $op")
+ error("bad type in $op")
unless defined $type_bit{$_} or $type eq '*';
+ $_ eq 'r' and
+ error("$op: 'r' is not allowed in transformations")
}
}
@@ -1331,14 +2194,17 @@ sub tr_parse_op {
}
# Get an optional value. (In destination.)
+ $type_val = $type eq 'x' ? 1023 : 0;
if (/^=(.*)/) {
+ error("value not allowed in source: $op")
+ if $src;
$type_val = $1;
$_ = '';
}
# Nothing more is allowed after the command.
- &error("garbage '$_' after operand: $op")
+ error("garbage '$_' after operand: $op")
unless /^\s*$/;
# Test that destination has no conditions.
@@ -1350,11 +2216,6 @@ sub tr_parse_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);
}
@@ -1369,8 +2230,7 @@ sub tr_gen {
foreach $ref (@g) {
my($line, $orig_transform, $from_ref, $to_ref) = @$ref;
- my $used_ref = used_vars($from_ref, $to_ref);
- my $so_far = tr_gen_from($line, $used_ref, @$from_ref);
+ my $so_far = tr_gen_from($line, @$from_ref);
tr_gen_to($line, $orig_transform, $so_far, @$to_ref);
}
@@ -1378,7 +2238,7 @@ sub tr_gen {
# Print the generated transformation engine.
#
my($offset) = 0;
- print "Uint op_transform[] = {\n";
+ print "const Uint op_transform[] = {\n";
foreach $key (sort keys %gen_transform) {
$gen_transform_offset{$key} = $offset;
my @instr = @{$gen_transform{$key}};
@@ -1421,58 +2281,14 @@ sub tr_gen {
print "};\n\n";
}
-sub used_vars {
- my($from_ref,$to_ref) = @_;
- my %used;
- my %seen;
-
- foreach my $ref (@$from_ref) {
- my($name,$arity,@ops) = @$ref;
- if ($name =~ /^[.]/) {
- foreach my $var (@ops) {
- $used{$var} = 1;
- }
- } else {
- # Any variable that is used at least twice on the
- # left-hand side is used. (E.g. "move R R".)
- foreach my $op (@ops) {
- my($var, $type, $type_val) = @$op;
- next if $var eq '';
- $used{$var} = 1 if $seen{$var};
- $seen{$var} = 1;
- }
- }
- }
-
- foreach my $ref (@$to_ref) {
- my($name, $arity, @ops) = @$ref;
- if ($name =~ /^[.]/) {
- foreach my $var (@ops) {
- $used{$var} = 1;
- }
- } else {
- foreach my $op (@ops) {
- my($var, $type, $type_val) = @$op;
- next if $var eq '';
- $used{$var} = 1;
- }
- }
- }
- \%used;
-}
-
sub tr_gen_from {
- my($line,$used_ref,@tr) = @_;
+ 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: ";
- my %var_used = %$used_ref;
my $may_fail = 0;
my $is_first = 1;
@@ -1494,8 +2310,20 @@ sub tr_gen_from {
my $var;
my(@args);
- push(@fix_pred_funcs, scalar(@code));
- push(@code, [$name, @ops]);
+ 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, "rest_args");
+ }
+ }
+ my $pi = tr_next_index(\@pred_table, \%pred_table, $name, @args);
+ my $op = make_op("$name()", 'pred', $pi);
+ my @slots = grep(/^\d+/, map { $var{$_} } @ops);
+ op_slot_usage($op, @slots);
+ push(@code, $op);
next;
}
@@ -1503,12 +2331,11 @@ sub tr_gen_from {
# Check that $name/$arity refers to a valid generic instruction.
#
- &error($where, "invalid generic op $name/$arity")
+ error($where, "invalid generic op $name/$arity")
unless defined $gen_opnum{$name,$arity};
$opnum = $gen_opnum{$name,$arity};
push(@code, make_op("$name/$arity", 'next_instr', $opnum));
- $min_window++;
foreach $op (@ops) {
my($var, $type, $type_val, $cond, $val) = @$op;
my $ignored_var = "$var (ignored)";
@@ -1532,11 +2359,11 @@ sub tr_gen_from {
$type_mask |= $type_bit{$_};
}
if ($cond ne 'is_eq') {
- push(@code, &make_op($types, 'is_type', $type_mask));
+ push(@code, make_op($types, 'is_type', $type_mask));
} else {
$cond = '';
- push(@code, &make_op("$types== $val", 'is_type_eq',
- $type_mask, $val));
+ push(@code, make_op("$types== $val", 'is_type_eq',
+ $type_mask, $val));
}
}
}
@@ -1545,32 +2372,38 @@ sub tr_gen_from {
my($m, $f, $a) = split(/:/, $val);
$ignored_var = '';
$may_fail = 1;
- push(@code, &make_op('', "$cond", "am_$m",
+ push(@code, make_op('', "$cond", "am_$m",
"am_$f", $a));
} elsif ($cond ne '') {
$ignored_var = '';
$may_fail = 1;
- push(@code, &make_op('', "$cond", $val));
+ push(@code, make_op('', "$cond", $val));
}
if ($var ne '') {
if (defined $var{$var}) {
$ignored_var = '';
$may_fail = 1;
- push(@code, &make_op($var, 'is_same_var', $var{$var}));
+ my $op = make_op($var, 'is_same_var', $var{$var});
+ op_slot_usage($op, $var{$var});
+ push(@code, $op);
} elsif ($type eq '*') {
- #
- # Reserve a hole for a 'rest_args' instruction.
- #
+ foreach my $type (values %var_type) {
+ error("only one use of a '*' variable is " .
+ "allowed on the left hand side of " .
+ "a transformation")
+ if $type eq 'array';
+ }
$ignored_var = '';
- push(@fix_rest_args, scalar(@code));
- push(@code, $var);
- } elsif ($var_used{$var}) {
+ $var{$var} = 'unnumbered';
+ $var_type{$var} = 'array';
+ push(@code, make_op($var, 'rest_args'));
+ } else {
$ignored_var = '';
$var_type{$var} = 'scalar';
$var{$var} = $var_num;
$var_num++;
- push(@code, &make_op($var, 'set_var', $var{$var}));
+ push(@code, make_op($var, 'set_var', $var{$var}));
}
}
if (is_instr($code[$#code], 'set_var')) {
@@ -1579,7 +2412,7 @@ sub tr_gen_from {
my $var = $ref->[1][1];
push(@code, make_op($comment, 'set_var_next_arg', $var));
} else {
- push(@code, &make_op($ignored_var, 'next_arg'));
+ push(@code, make_op($ignored_var, 'next_arg'));
}
}
@@ -1593,46 +2426,14 @@ sub tr_gen_from {
#
push(@code, make_op($may_fail ? '' : 'always reached', '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}");
- }
- }
- my $pi = tr_next_index(\@pred_table, \%pred_table, $name, @args);
- splice(@code, $index, 1, make_op("$name()", 'pred', $pi));
- }
-
$te_max_vars = $var_num
if $te_max_vars < $var_num;
- [$min_window, \%var, \%var_type, \@code];
+ [\%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_ref, $var_type_ref, $code_ref) = @$so_far;
my(%var) = %$var_ref;
my(%var_type) = %$var_type_ref;
my(@code) = @$code_ref;
@@ -1656,18 +2457,21 @@ sub tr_gen_to {
my(@args);
foreach $var (@ops) {
- &error($where, "variable '$var' unbound")
+ 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}");
+ push(@args, "rest_args");
}
}
pop(@code); # Get rid of 'commit' instruction
my $index = tr_next_index(\@call_table, \%call_table,
$name, @args);
- push(@code, make_op("$name()", 'call_end', $index));
+ my $op = make_op("$name()", 'call_end', $index);
+ my @slots = grep(/^\d+/, map { $var{$_} } @ops);
+ op_slot_usage($op, @slots);
+ push(@code, $op);
last;
}
@@ -1676,7 +2480,7 @@ sub tr_gen_to {
#
my($key) = "$name/$arity";
- &error($where, "invalid generic op $name/$arity")
+ error($where, "invalid generic op $name/$arity")
unless defined $gen_opnum{$name,$arity};
my $opnum = $gen_opnum{$name,$arity};
@@ -1689,15 +2493,17 @@ sub tr_gen_to {
my($var, $type, $type_val) = @$op;
if ($type eq '*') {
- push(@code, make_op($var, 'store_rest_args', $var{$var}));
+ push(@code, make_op($var, 'store_rest_args'));
} elsif ($var ne '') {
- &error($where, "variable '$var' unbound")
+ error($where, "variable '$var' unbound")
unless defined $var{$var};
- push(@code, &make_op($var, 'store_var_next_arg', $var{$var}));
+ my $op = make_op($var, 'store_var_next_arg', $var{$var});
+ op_slot_usage($op, $var{$var});
+ push(@code, $op);
} elsif ($type ne '') {
- push(@code, &make_op('', 'store_type', "TAG_$type"));
+ push(@code, make_op('', 'store_type', "TAG_$type"));
if ($type_val) {
- push(@code, &make_op('', 'store_val', $type_val));
+ push(@code, make_op('', 'store_val', $type_val));
}
push(@code, make_op('', 'next_arg'));
}
@@ -1708,6 +2514,10 @@ sub tr_gen_to {
push(@code, make_op('', 'end'))
unless is_instr($code[$#code], 'call_end');
+ tr_maybe_keep(\@code);
+ tr_maybe_rename(\@code);
+ tr_remove_unused(\@code);
+
#
# Chain together all codes segments having the same first operation.
#
@@ -1716,8 +2526,6 @@ sub tr_gen_to {
my($dummy, $arity);
($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;
my $prev_last;
$prev_last = pop(@{$gen_transform{$key}})
@@ -1735,6 +2543,148 @@ sub tr_gen_to {
push(@{$gen_transform{$key}}, @code),
}
+sub tr_maybe_keep {
+ my($ref) = @_;
+ my @last_instr;
+ my $pos;
+ my $reused_instr;
+
+ for (my $i = 0; $i < @$ref; $i++) {
+ my $instr = $$ref[$i];
+ my($size, $instr_ref, $comment) = @$instr;
+ my($op, @args) = @$instr_ref;
+ if ($op eq 'next_instr') {
+ @last_instr = ($args[0]);
+ } elsif ($op eq 'set_var_next_arg') {
+ push @last_instr, $args[0];
+ } elsif ($op eq 'next_arg') {
+ push @last_instr, 'ignored';
+ } elsif ($op eq 'new_instr') {
+ unless (defined $pos) {
+ # 'new_instr' immediately after 'commit'.
+ $reused_instr = $args[0];
+ return unless shift(@last_instr) == $reused_instr;
+ $pos = $i - 1;
+ } else {
+ # Second 'new_instr' after 'commit'. The instructions
+ # from $pos up to and including $i - 1 rebuilds the
+ # existing instruction exactly.
+ my $name = $gen_opname[$reused_instr];
+ my $arity = $gen_arity[$reused_instr];
+ my $reuse = make_op("$name/$arity", 'keep');
+ splice @$ref, $pos, $i-$pos, ($reuse);
+ return;
+ }
+ } elsif ($op eq 'store_var_next_arg') {
+ return unless shift(@last_instr) eq $args[0];
+ } elsif (defined $pos) {
+ return;
+ }
+ }
+}
+
+sub tr_maybe_rename {
+ my($ref) = @_;
+ my $s = 'left';
+ my $a = 0;
+ my $num_args = 0;
+ my $new_instr;
+ my $first;
+ my $i;
+
+ for ($i = 1; $i < @$ref; $i++) {
+ my $instr = $$ref[$i];
+ my($size, $instr_ref, $comment) = @$instr;
+ my($op, @args) = @$instr_ref;
+
+ if ($s eq 'left') {
+ if ($op eq 'set_var_next_arg') {
+ if ($num_args == $a and $args[0] == $a) {
+ $num_args++;
+ }
+ $a++;
+ } elsif ($op eq 'next_arg') {
+ $a++;
+ } elsif ($op eq 'commit') {
+ $a = 0;
+ $first = $i;
+ $s = 'committed';
+ } elsif ($op eq 'next_instr') {
+ return;
+ }
+ } elsif ($s eq 'committed') {
+ if ($op eq 'new_instr') {
+ $new_instr = $args[0];
+ $a = 0;
+ $s = 'right';
+ } else {
+ return;
+ }
+ } elsif ($s eq 'right') {
+ if ($op eq 'store_var_next_arg' && $args[0] == $a) {
+ $a++;
+ } elsif ($op eq 'end' && $a <= $num_args) {
+ my $name = $gen_opname[$new_instr];
+ my $arity = $gen_arity[$new_instr];
+ my $new_op = make_op("$name/$arity", 'rename', $new_instr);
+ splice @$ref, $first, $i-$first+1, ($new_op);
+ return;
+ } else {
+ return;
+ }
+ }
+ }
+}
+
+sub tr_remove_unused {
+ my($ref) = @_;
+ my %used;
+
+ # Collect all used variables.
+ for my $instr (@$ref) {
+ my $uref = $$instr[3];
+ for my $slot (@$uref) {
+ $used{$slot} = 1;
+ }
+ }
+
+ # Replace 'set_var_next_arg' with 'next_arg' if the variable
+ # is never used.
+ for my $instr (@$ref) {
+ my($size, $instr_ref, $comment) = @$instr;
+ my($op, @args) = @$instr_ref;
+ if ($op eq 'set_var_next_arg') {
+ my $var = $args[0];
+ next if $used{$var};
+ $instr = make_op("$comment (ignored)", 'next_arg');
+ }
+ }
+
+ # Delete a sequence of 'next_arg' instructions when they are
+ # redundant before instructions such as 'commit'.
+ my @opcode;
+ my %ending = (call_end => 1,
+ commit => 1,
+ next_instr => 1,
+ pred => 1,
+ rename => 1,
+ keep => 1);
+ for (my $i = 0; $i < @$ref; $i++) {
+ my $instr = $$ref[$i];
+ my($size, $instr_ref, $comment) = @$instr;
+ my($opcode) = @$instr_ref;
+
+ if ($ending{$opcode}) {
+ my $first = $i;
+ $first-- while $first > 0 and $opcode[$first-1] eq 'next_arg';
+ my $n = $i - $first;
+ splice @$ref, $first, $n;
+ $i -= $n;
+ }
+ $opcode[$i] = $opcode;
+ }
+}
+
sub tr_code_len {
my($sum) = 0;
my($ref);
@@ -1747,7 +2697,12 @@ sub tr_code_len {
sub make_op {
my($comment, @op) = @_;
- [scalar(@op), [@op], $comment];
+ [scalar(@op), [@op], $comment, []];
+}
+
+sub op_slot_usage {
+ my($op_ref, @slots) = @_;
+ $$op_ref[3] = \@slots;
}
sub is_instr {
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-24 13:41:01 +0000