diff options
Diffstat (limited to 'erts/emulator/utils')
| -rwxr-xr-x | erts/emulator/utils/beam_makeops | 259 |
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; |