diff options
Diffstat (limited to 'erts/emulator/utils')
| -rwxr-xr-x | erts/emulator/utils/beam_makeops | 304 |
1 files changed, 215 insertions, 89 deletions
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops index 64a9a49ac8..388e3d164d 100755 --- a/erts/emulator/utils/beam_makeops +++ b/erts/emulator/utils/beam_makeops @@ -24,6 +24,16 @@ 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; + +# 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 +42,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 +245,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 +257,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; + } + } } # @@ -732,12 +735,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"; @@ -1138,7 +1148,7 @@ 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($s, @first); $offsets{$s} = $offset unless defined $offsets{$s} and $offsets{$s} < $offset; $offset += $size - 1; @@ -1229,7 +1239,7 @@ sub combine_instruction_group { } my($gen_code,$down,$up) = - cg_combined_code($s, 1, $flags, $offset, + cg_combined_code($s, $flags, $offset, $group_size-$offset, $inc, @first); my $spec_label = "$opcase$label"; $down{$spec_label} = $down; @@ -1280,7 +1290,7 @@ sub micro_label { sub cg_basic { my($name,@args) = @_; - my($size,$code,$pack_spec) = code_gen($name, 1, '', 0, undef, undef, @args); + my($size,$code,$pack_spec) = code_gen($name, \@extended_pack_options, '', 0, undef, undef, @args); $pack_spec = build_pack_spec($pack_spec); ($size,$code,$pack_spec); } @@ -1290,8 +1300,8 @@ sub cg_basic { # sub cg_combined_size { - my($name,$pack,@args) = @_; - my($size) = code_gen($name, $pack, '', 0, undef, undef, @args); + my($name,@args) = @_; + my($size) = code_gen($name, \@basic_pack_options, '', 0, undef, undef, @args); $size; } @@ -1300,8 +1310,9 @@ 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($name,$extra,$offset,$comp_size,$inc,@args) = @_; + my($size,$code,$pack_spec) = + code_gen($name, \@basic_pack_options, $extra, $offset, $comp_size, $inc, @args); if ($pack_spec eq '') { ($code,'',''); } else { @@ -1311,7 +1322,7 @@ sub cg_combined_code { } sub code_gen { - my($name,$pack,$extra_comments,$offset,$comp_size,$inc,@args) = @_; + my($name,$pack_options,$extra_comments,$offset,$comp_size,$inc,@args) = @_; my $group_size = defined $comp_size ? $comp_size + $inc : undef; my $size = 0; my $flags = ''; @@ -1326,8 +1337,8 @@ 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') { + ($var_decls, $pack_spec, @args) = do_pack($offset, $pack_options, @args); } # @@ -1603,9 +1614,25 @@ sub needs_do_wrapper { } sub do_pack { - my($offset,@args) = @_; + my($offset,$pack_options,@args) = @_; + my $ret = ['', ':', @args]; + my $score = 0; + + foreach my $options (@$pack_options) { + my($this_score,$this_result) = do_pack_one($options, $offset, @args); + if ($this_score > $score) { + $ret = $this_result; + $score = $this_score; + } + } + return @$ret; +} + +sub do_pack_one { + my($options,$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 +1646,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 +1662,46 @@ 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 !$pack_in_iw) { + 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; + 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 $i = 0; $i < @args; $i++) { - if ($bits_needed[$i]) { my $needed = $bits_needed[$i]; + next unless $needed; - my $next_word = sub { - $word++; - $args_per_word[$word] = 0; - $need_wide_mask[$word] = 0; - $bits = 0; - }; - - 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 +1721,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 { @@ -1753,43 +1780,51 @@ 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($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 { @@ -1809,7 +1844,98 @@ sub do_pack { } 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($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("internal 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 + $max_spec_operands*($max_spec_operands - $size); + if ($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 { |