aboutsummaryrefslogtreecommitdiffstats
path: root/erts/emulator/utils
diff options
context:
space:
mode:
Diffstat (limited to 'erts/emulator/utils')
-rwxr-xr-xerts/emulator/utils/beam_makeops486
1 files changed, 348 insertions, 138 deletions
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops
index 64a9a49ac8..d7791d23fa 100755
--- a/erts/emulator/utils/beam_makeops
+++ b/erts/emulator/utils/beam_makeops
@@ -24,6 +24,17 @@ 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;
@@ -32,30 +43,15 @@ my $verbose = 0;
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.
@@ -250,6 +246,7 @@ 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";
@@ -261,14 +258,21 @@ if ($wordsize == 32) {
} elsif ($wordsize == 64) {
$defs{'ARCH_32'} = 0;
$defs{'ARCH_64'} = 1;
+ $code_pointers_are_short = $code_model eq 'small';
}
#
-# Initialize number of arguments per packed word.
+# Initialize pack options.
#
if ($wordsize == 64) {
- $pack_mask[3] = ['BEAM_TIGHT_MASK', 'BEAM_TIGHT_MASK', $WHOLE_WORD];
+ @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;
+ }
+ }
}
#
@@ -450,15 +454,7 @@ 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");
- }
- save_specific_ops($name, $arity, $hotness, @args);
+ my($name,$arity) = parse_specific_op($_);
if (defined $op_num) {
error("specific instructions must not be numbered");
} elsif (!defined($gen_arity{$name}) && !defined($unnumbered{$name,$arity})) {
@@ -531,10 +527,9 @@ sub emulator_output {
foreach $key (keys %specific_op) {
foreach (@{$specific_op{$key}}) {
my($name, $hotness, @args) = @$_;
- my $sign = join('', @args);
my $print_name = print_name($name, @args);
- my($size, $code, $pack_spec) = cg_basic($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)];
@@ -602,6 +597,7 @@ 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.
@@ -619,6 +615,7 @@ sub emulator_output {
my $print_name = $items{$sort_key};
my $info = $spec_op_info{$print_name};
my(@args) = @{$info->{'args'}};
+ @args = map { s/[?]$//; $_ } @args;
my $arity = @args;
#
@@ -732,12 +729,19 @@ sub emulator_output {
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";
@@ -852,6 +856,7 @@ sub emulator_output {
sub print_name {
my($name,@args) = @_;
my $sign = join '', @args;
+ $sign =~ s/[?]//g;
$sign ne '' ? "${name}_$sign" : $name;
}
@@ -971,40 +976,54 @@ 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;
+ # Check for various errors.
error("Bad opcode name '$name'")
unless $name =~ /^[a-z][\w\d_]*$/;
- for ($i = 0; $i < @args; $i++) {
- foreach my $type (split(//, $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};
}
}
-}
-
-sub save_specific_ops {
- my($name,$arity,$hot,@args) = @_;
- my(@res) = ("");
+ 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 @new_res = ();
+ my @old_res = @res;
+ @res = ();
+ my $marker = ($arg =~ s/[?]$//) ? '?' : '';
foreach my $type (split(//, $arg)) {
- foreach my $args (@res) {
- push @new_res, "$args$type";
+ foreach my $args_ref (@old_res) {
+ my @args = @$args_ref;
+ push @args, "$type$marker";
+ push @res, \@args;
}
}
- @res = @new_res;
}
+
+ # Store each specific instruction.
my $key = "$name/$arity";
- foreach my $args (@res) {
- @args = split //, $args;
- push @{$specific_op{$key}}, [$name,$hot,@args];
+ foreach my $args_ref (@res) {
+ @args = @$args_ref;
+ push @{$specific_op{$key}}, [$name,$hotness,@args];
}
+
+ # Done.
+ ($name,$arity);
}
sub parse_c_args {
@@ -1110,9 +1129,28 @@ sub combine_instruction_group {
# Variables.
my %offsets;
my @instrs;
- my %num_references;
+ my %num_references; # Number of references from other sub instructions.
my $group_size = 999;
+ #
+ # 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.
@@ -1138,12 +1176,13 @@ sub combine_instruction_group {
foreach (0..$#c_args) {
push @first, shift @rest;
}
- my $size = cg_combined_size($s, 1, @first);
+ 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);
- $num_references{$label} = 0;
push @new_subs, [$opcase,$label,$s,$size-1,@first];
$opcase = '';
}
@@ -1162,9 +1201,8 @@ sub combine_instruction_group {
my($opcase,$label,$s,$size,@args) = @{$subs[$i]};
my $next = '';
(undef,$next) = @{$subs[$i+1]} if $i < $#subs;
- $num_references{$next}++ if $next;
my $instr_info = "$opcase:$label:$next:$s:$size:@args";
- push @all_instrs, [$label,$offsets{$s},$instr_info];
+ push @all_instrs, [$label,$s,$offsets{$s},$instr_info];
}
}
@@ -1172,8 +1210,8 @@ sub combine_instruction_group {
my %label_to_offset;
my %order_to_offset;
foreach my $instr (@all_instrs) {
- my($label,$offset,$instr_info) = @$instr;
- my $sort_key = sprintf("%02d.%02d", $offset, $num_references{$label});
+ 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;
@@ -1212,7 +1250,7 @@ sub combine_instruction_group {
$gcode .= "OpCase($opcase):\n";
push @opcase_labels, $opcase;
}
- if ($num_references{$label}) {
+ if ($num_references{$s}) {
$gcode .= "$label:\n";
}
@@ -1229,8 +1267,13 @@ sub combine_instruction_group {
}
my($gen_code,$down,$up) =
- cg_combined_code($s, 1, $flags, $offset,
- $group_size-$offset, $inc, @first);
+ 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;
@@ -1279,8 +1322,8 @@ sub micro_label {
#
sub cg_basic {
- my($name,@args) = @_;
- my($size,$code,$pack_spec) = code_gen($name, 1, '', 0, undef, undef, @args);
+ 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);
}
@@ -1290,8 +1333,10 @@ sub cg_basic {
#
sub cg_combined_size {
- my($name,$pack,@args) = @_;
- my($size) = code_gen($name, $pack, '', 0, undef, undef, @args);
+ my %params = (@_, pack_options => \@basic_pack_options);
+ $params{pack_options} = \@extended_pack_options
+ if $params{first};
+ my($size) = code_gen(%params);
$size;
}
@@ -1300,8 +1345,10 @@ sub cg_combined_size {
#
sub cg_combined_code {
- my($name,$pack,$extra_comments,$offset,$comp_size,$inc,@args) = @_;
- my($size,$code,$pack_spec) = code_gen(@_);
+ 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 {
@@ -1311,8 +1358,16 @@ sub cg_combined_code {
}
sub code_gen {
- my($name,$pack,$extra_comments,$offset,$comp_size,$inc,@args) = @_;
- my $group_size = defined $comp_size ? $comp_size + $inc : undef;
+ 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;
@@ -1326,8 +1381,9 @@ sub code_gen {
#
my $c_code_ref = $c_code{$name};
- if ($pack and defined $c_code_ref and $name ne 'catch') {
- ($var_decls, $pack_spec, @args) = do_pack($offset, @args);
+ 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);
}
#
@@ -1337,6 +1393,7 @@ sub code_gen {
my $need_block = 0;
my $arg_offset = $offset;
+ @args = map { s/[?]$//g; $_ } @args;
foreach (@args) {
my($this_size) = $arg_size{$_};
SWITCH:
@@ -1399,7 +1456,7 @@ sub code_gen {
return ($size+1, undef, '');
}
- $group_size = $size unless defined $group_size;
+ my $group_size = ($params{comp_size} || $size) + $inc;
#
# Generate main body of the implementation.
@@ -1418,7 +1475,7 @@ sub code_gen {
$bindings{$var} = $f[$i];
}
$bindings{'NEXT_INSTRUCTION'} = "I+" . ($group_size+$offset+1);
- $bindings{'IP_ADJUSTMENT'} = defined $inc ? $inc : 0;
+ $bindings{'IP_ADJUSTMENT'} = $inc;
$c_code = eval { expand_all($c_code, \%bindings) };
unless (defined $c_code) {
warn $@;
@@ -1441,10 +1498,10 @@ sub code_gen {
"ASSERT(VALID_INSTR(*I));\n" .
"Goto(*I);";
} else {
- $var_decls .= "BeamInstr next_pf = I[$instr_offset];\n";
+ $var_decls .= "BeamInstr next_pf = BeamCodeAddr(I[$instr_offset]);\n";
$dispatch_next = "\nI += $instr_offset;\n" .
"ASSERT(VALID_INSTR(next_pf));\n" .
- "Goto(next_pf);";
+ "GotoPF(next_pf);";
}
#
@@ -1603,9 +1660,51 @@ sub needs_do_wrapper {
}
sub do_pack {
- my($offset,@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 @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.
@@ -1619,6 +1718,10 @@ sub do_pack {
't' => 16);
if ($wordsize == 64) {
$bits_needed{'I'} = 32;
+ if ($options & PACK_JUMP) {
+ $bits_needed{'f'} = 32;
+ $bits_needed{'j'} = 32;
+ }
}
#
@@ -1631,51 +1734,48 @@ sub do_pack {
} else {
push @bits_needed, 0;
}
- }
-
- #
- # Try to pack 'f' and 'j', but not at expense at worse packing
- # for other operands. For example, given the arguments "f x x", we
- # want the 'x' operands to be packed, not 'f' and 'x' packed and
- # the final 'x' not packed.
- #
-
- if ($wordsize == 64 and $packable_args == 1) {
- for (my $i = 0; $i < @args; $i++) {
- if ($args[$i] =~ /^[fj]$/) {
- $bits_needed[$i] = 32;
- $packable_args++;
- last;
- }
+ if ($arg =~ /^[fj]$/) {
+ # Only pack the first occurrence of 'f' or 'j'.
+ delete $bits_needed{'f'};
+ delete $bits_needed{'j'};
}
}
#
- # Nothing to pack unless there are at least 2 packable arguments.
+ # Return if there is nothing to pack.
#
- return ('', ':', @args) if $packable_args < 2;
+ if ($packable_args == 0) {
+ return (-1);
+ } elsif ($packable_args == 1 and $options == 0) {
+ return (-1);
+ }
#
# 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;
- };
+ 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;
+ };
+
+ $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 > $wordsize) { # Does not fit.
+ if ($bits+$needed > $this_wordsize) { # Does not fit.
$next_word->();
}
if ($args_per_word[$word] == 4) { # Can't handle more than 4 args.
@@ -1695,15 +1795,16 @@ sub do_pack {
# Can only pack two things in a word where one
# item is 32 bits. Force the next item into
# the next word.
- $bits = $wordsize;
+ $bits = $this_wordsize;
}
- }
}
#
# Try to balance packing between words.
#
- if ($args_per_word[$#args_per_word] == 1) {
+ 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 {
@@ -1728,12 +1829,19 @@ sub do_pack {
# beginning).
my $up = ''; # Pack commands (storing back while
# moving forward).
+ my $arg_num = 0; # Number of argument.
- # Skip an unpackable argument.
+ # Skip an unpackable argument. Also handle packing of
+ # an single operand into the instruction word.
my $skip_unpackable = sub {
my($arg) = @_;
- if ($arg_size{$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'}) {
@@ -1753,43 +1861,50 @@ sub do_pack {
# 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.
-
- 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', 'w');
- } else {
- @shift = @{$pack_shift[$args_per_word]};
- @mask = @{$pack_mask[$args_per_word]};
- @instr = @{$pack_instr[$args_per_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) {
- $pack_prefix .= "Eterm $packed_var = " .
- arg_offset($size+$offset) . ";\n";
- $up .= "p";
- $down = "P$down";
- $this_size = 1;
+ 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]);
- $args[$arg_num] = "packed:$reg:$this_size:$reg" . "b($unpack)";
+ my $macro = "$reg$unpack_suffix";
+ $args[$arg_num] = "packed:$reg:$this_size:$macro($unpack)";
$ap++;
} else {
@@ -1804,12 +1919,107 @@ sub do_pack {
# Skip any unpackable arguments at the end.
#
while ($arg_num < @args) {
- $skip_unpackable->($args[$arg_num]);
+ my $arg = $args[$arg_num];
+ $skip_unpackable->($arg);
+ $size += $arg_size{$arg};
$arg_num++;
}
my $pack_spec = "$down:$up";
- return ($pack_prefix, $pack_spec, @args);
+ my $score = pack_score($options, @args);
+
+ return ($score, [$pack_prefix,$pack_spec,@args]);
+}
+
+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;
+
+ # 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 {