aboutsummaryrefslogtreecommitdiffstats
path: root/erts/emulator/utils
diff options
context:
space:
mode:
Diffstat (limited to 'erts/emulator/utils')
-rwxr-xr-xerts/emulator/utils/beam_makeops259
1 files changed, 165 insertions, 94 deletions
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops
index 4108138b51..2a957d2c9d 100755
--- a/erts/emulator/utils/beam_makeops
+++ b/erts/emulator/utils/beam_makeops
@@ -54,11 +54,6 @@ $pack_mask[4] = ['BEAM_LOOSE_MASK', # Only for 64 bit wordsize
'BEAM_LOOSE_MASK',
$WHOLE_WORD];
-# Mapping from packagable arguments to number of packed arguments per
-# word. Initialized after the wordsize is known.
-
-my @args_per_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
@@ -264,15 +259,8 @@ if ($wordsize == 32) {
# Initialize number of arguments per packed word.
#
-$args_per_word[2] = 2;
-$args_per_word[3] = 3;
-$args_per_word[4] = 2;
-$args_per_word[5] = 3;
-$args_per_word[6] = 3;
-
if ($wordsize == 64) {
$pack_mask[3] = ['BEAM_TIGHT_MASK', 'BEAM_TIGHT_MASK', $WHOLE_WORD];
- $args_per_word[4] = 4;
}
#
@@ -1240,7 +1228,7 @@ sub basic_generator {
my $c_code_ref = $c_code{$name};
if ($hot and defined $c_code_ref) {
- ($prefix, $pack_spec, @args) = do_pack(@args);
+ ($var_decls, $pack_spec, @args) = do_pack(@args);
}
#
@@ -1254,7 +1242,14 @@ sub basic_generator {
my($this_size) = $arg_size{$_};
SWITCH:
{
- /^pack:(\d):(.*)/ and do {
+ /^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;
@@ -1458,29 +1453,28 @@ sub expand_macro {
sub do_pack {
my(@args) = @_;
my($packable_args) = 0;
- my @is_packable; # Packability (boolean) for each argument.
- my $wide_packing = 0;
- my(@orig_args) = @args;
+ my @bits_needed; # Bits needed for each argument.
#
- # Count the number of packable arguments. If we encounter any 's' or 'd'
- # arguments, packing is not possible.
+ # Define the minimum number of bits needed for the packable argument types.
+ #
+ my %bits_needed = ('x' => 10,
+ 'y' => 10,
+ 'Q' => 10,
+ 'l' => 10,
+ 'd' => 16,
+ 't' => 16);
+ if ($wordsize == 64) {
+ $bits_needed{'I'} = 32;
+ }
+
+ #
+ # 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};
} elsif ($arg =~ /^[scq]/ and $packable_args > 0) {
# When packing, this operand will be picked up from the
# code array, put onto the packing stack, and later put
@@ -1494,87 +1488,164 @@ sub do_pack {
# just turn off packing.
return ('', '', @args);
} else {
- push @is_packable, 0;
+ push @bits_needed, 0;
}
}
#
- # Get out of here if too few or too many arguments.
+ # Nothing to pack unless there are at least 2 packable arguments.
#
return ('', '', @args) if $packable_args < 2;
- my($size) = 0;
- my($pack_prefix) = '';
- my($down) = ''; # Pack commands (towards instruction
+ #
+ # Determine how many arguments we should pack into each word.
+ #
+ my @args_per_word;
+ my @need_wide_mask;
+ my $bits = 0;
+ my $word = 0;
+ $args_per_word[0] = 0;
+ $need_wide_mask[0] = 0;
+ for (my $i = 0; $i < @args; $i++) {
+ if ($bits_needed[$i]) {
+ my $needed = $bits_needed[$i];
+
+ my $next_word = sub {
+ $word++;
+ $args_per_word[$word] = 0;
+ $need_wide_mask[$word] = 0;
+ $bits = 0;
+ };
+
+ if ($bits+$needed > $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 = $wordsize;
+ }
+ }
+ }
+
+ #
+ # Try to balance packing between words.
+ #
+ if ($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
+ my $up = ''; # Pack commands (storing back while
# moving forward).
+ my $did_some_packing = 0; # Nothing packed yet.
- my $args_per_word = $args_per_word[$packable_args];
- my @shift;
- my @mask;
- my @instr;
+ # Skip an unpackable argument.
+ my $skip_unpackable = sub {
+ my($arg) = @_;
- 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]};
- }
+ if ($arg_size{$arg} and $did_some_packing) {
+ # Save the argument on the pack engine's stack.
+ $down = "g${down}";
+ $up = "${up}p";
+ } else {
+ # The argument has either zero size (e.g. r(0)),
+ # or is to the left of the first packed argument
+ # and will never be accessed. No need to do
+ # anything.
+ }
+ };
#
# 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 .= "Eterm tmp_packed$tmpnum = Arg($size);\n";
- $up .= "p";
- $down = "P$down";
- $this_size = 1;
- }
+ my $arg_num = 0;
+ 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 @shift;
+ my @mask;
+ my @instr;
+
+ if ($need_wide_mask[$word]) {
+ @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]};
+ }
- $down = "$instr[$ap]$down";
- my($unpack) = make_unpack($tmpnum, $shift[$ap], $mask[$ap]);
- $args[$i] = "pack:$this_size:$reg" . "b($unpack)";
+ while ($ap < $args_per_word) {
+ my $reg = $args[$arg_num];
+ my $this_size = $arg_size{$reg};
+ if ($bits_needed[$arg_num]) {
+ $this_size = 0;
+ $did_some_packing = 1;
+
+ if ($ap == 0) {
+ $pack_prefix .= "Eterm $packed_var = Arg($size);\n";
+ $up .= "p";
+ $down = "P$down";
+ $this_size = 1;
+ }
- 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 = "$instr[$ap]$down";
+ my $unpack = make_unpack($packed_var, $shift[$ap], $mask[$ap]);
+ $args[$arg_num] = "packed:$reg:$this_size:$reg" . "b($unpack)";
- $down = "g${down}";
- $up = "${up}p";
- }
- $size += $this_size;
+ $ap++;
+ } else {
+ $skip_unpackable->($reg);
+ }
+ $size += $this_size;
+ $arg_num++;
+ }
+ }
+
+ #
+ # Skip any unpackable arguments at the end.
+ #
+ while ($arg_num < @args) {
+ $skip_unpackable->($args[$arg_num]);
+ $arg_num++;
}
my $pack_spec = $down . $up;
@@ -1582,9 +1653,9 @@ sub do_pack {
}
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;