diff options
Diffstat (limited to 'erts/emulator/utils/beam_makeops')
| -rwxr-xr-x | erts/emulator/utils/beam_makeops | 432 |
1 files changed, 283 insertions, 149 deletions
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops index 0b7c16f606..4407f7e289 100755 --- a/erts/emulator/utils/beam_makeops +++ b/erts/emulator/utils/beam_makeops @@ -2,18 +2,19 @@ # # %CopyrightBegin% # -# Copyright Ericsson AB 1998-2012. All Rights Reserved. +# Copyright Ericsson AB 1998-2016. 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% # @@ -53,6 +54,11 @@ $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 @@ -107,7 +113,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; @@ -175,11 +180,12 @@ 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('j', $type_bit{'f'} | $type_bit{'p'}); # Aliases (for matching purposes). @@ -235,6 +241,21 @@ while (@ARGV && $ARGV[0] =~ /^-(.*)/) { } # +# 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; +} + +# # Parse the input files. # @@ -361,7 +382,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]); @@ -419,7 +439,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; } } @@ -526,12 +545,16 @@ 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; @@ -543,7 +566,7 @@ sub emulator_output { $sep = ","; } $init .= "}"; - &init_item($print_name, $init, $size, $pack, $sign, 0); + init_item($print_name, $init, $involves_r, $size, $pack, $sign, 0); $op_to_name[$spec_opnum] = $instr; $spec_opnum++; } @@ -582,7 +605,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"; @@ -600,24 +623,27 @@ 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"; + print "#define BEAM_WIDE_MASK 0xFFFFUL\n"; + print "#define BEAM_LOOSE_MASK 0xFFFFUL\n"; + print "#define BEAM_TIGHT_MASK 0xFFFFUL\n"; + print "#define BEAM_WIDE_SHIFT 32\n"; + print "#define BEAM_LOOSE_SHIFT 16\n"; + print "#define BEAM_TIGHT_SHIFT 16\n"; + } print "\n"; # @@ -733,7 +759,7 @@ sub init_item { print "${sep}NULL"; } elsif (/^\{/) { print "$sep$_"; - } elsif (/^-?\d/) { + } elsif (/^-?\d+$/) { print "$sep$_"; } else { print "$sep\"$_\""; @@ -895,6 +921,7 @@ sub basic_generator { my($var_decls) = ''; my($gen_dest_arg) = 'StoreSimpleDest'; my($i); + my($no_prefetch) = 0; # The following argument types should be included as macro arguments. my(%incl_arg) = ('c' => 1, @@ -993,6 +1020,7 @@ sub basic_generator { # $flags =~ /-fail_action/ and do { + $no_prefetch = 1; if (!defined $fail_type) { my($i); for ($i = 0; $i < @f_types; $i++) { @@ -1039,6 +1067,12 @@ sub basic_generator { "I += $size + 1;", "goto $goto;", "}"); + } elsif ($no_prefetch) { + $code = join("\n", + "{ $var_decls", + $macro_code, + "Next($size);", + "}", ""); } else { $code = join("\n", "{ $var_decls", @@ -1060,6 +1094,7 @@ sub do_pack { my($packable_args) = 0; my @is_packable; # Packability (boolean) for each argument. my $wide_packing = 0; + my(@orig_args) = @args; # # Count the number of packable arguments. If we encounter any 's' or 'd' @@ -1080,6 +1115,18 @@ sub do_pack { } } elsif ($arg =~ /^[sd]/) { return ('', '', @args); + } 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 + # back into a different location in the code. The problem + # is that if this operand is a literal, the original + # location in the code would have been remembered in a + # literal patch. For packing to work, we would have to + # adjust the position in the literal patch. For the + # moment, adding additional instructions to the packing + # engine to handle this does not seem worth it, so we will + # just turn off packing. + return ('', '', @args); } else { push @is_packable, 0; } @@ -1089,7 +1136,6 @@ sub do_pack { # Get out of here if too few or too many arguments. # return ('', '', @args) if $packable_args < 2; - &error("too many packable arguments") if $packable_args > 4; my($size) = 0; my($pack_prefix) = ''; @@ -1097,14 +1143,8 @@ sub do_pack { # 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; - } + my $args_per_word = $args_per_word[$packable_args]; my @shift; my @mask; my @instr; @@ -1298,6 +1338,8 @@ sub tr_parse_op { foreach (split('', $type)) { &error("bad type in $op") unless defined $type_bit{$_} or $type eq '*'; + $_ eq 'r' and + error("$op: 'r' is not allowed in transformations") } } @@ -1331,7 +1373,10 @@ 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; $_ = ''; } @@ -1350,11 +1395,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 +1409,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); } @@ -1421,58 +1460,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 +1489,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; } @@ -1508,7 +1515,6 @@ sub tr_gen_from { $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)"; @@ -1557,15 +1563,21 @@ sub tr_gen_from { 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; @@ -1593,46 +1605,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; @@ -1661,13 +1641,16 @@ sub tr_gen_to { 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; } @@ -1689,11 +1672,13 @@ 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") 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")); if ($type_val) { @@ -1708,6 +1693,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 +1705,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 +1722,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 +1876,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 { |