diff options
Diffstat (limited to 'erts/emulator/utils/beam_makeops')
| -rwxr-xr-x | erts/emulator/utils/beam_makeops | 209 |
1 files changed, 163 insertions, 46 deletions
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops index 4a859c3094..ebf7db3277 100755 --- a/erts/emulator/utils/beam_makeops +++ b/erts/emulator/utils/beam_makeops @@ -1,20 +1,20 @@ #!/usr/bin/env perl # # %CopyrightBegin% -# -# Copyright Ericsson AB 1998-2009. All Rights Reserved. -# +# +# Copyright Ericsson AB 1998-2011. 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/. -# +# # 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. -# +# # %CopyrightEnd% # use strict; @@ -27,6 +27,7 @@ my $outdir = "."; # Directory for output files. my $verbose = 0; my $hot = 1; my $num_file_opcodes = 0; +my $wordsize = 32; # This is shift counts and mask for the packer. my $WHOLE_WORD = ''; @@ -36,12 +37,20 @@ 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]; # There are two types of instructions: generic and specific. # The generic instructions are those generated by the Beam compiler. @@ -58,6 +67,10 @@ my $max_gen_operands = 8; # Must be even. The beam_load.c file must be updated, too. my $max_spec_operands = 6; +# The maximum number of primitive genop_types. + +my $max_genop_types = 16; + my %gen_opnum; my %num_specific; my %gen_to_spec; @@ -80,6 +93,8 @@ my %cold_code; my @unnumbered_generic; my %unnumbered; +my %is_transformed; + # # Code transformations. # @@ -95,7 +110,7 @@ my @pred_table; # Operand types for generic instructions. my $compiler_types = "uiaxyfhz"; -my $loader_types = "nprvlq"; +my $loader_types = "nprvlqo"; my $genop_types = $compiler_types . $loader_types; # @@ -118,7 +133,8 @@ my %arg_size = ('r' => 0, # x(0) - x register zero 't' => 1, # untagged integer -- can be packed 'b' => 1, # pointer to bif 'A' => 1, # arity value - 'P' => 1, # byte offset into tuple + 'P' => 1, # byte offset into tuple or stack + 'Q' => 1, # like 'P', but packable 'h' => 1, # character 'l' => 1, # float reg 'q' => 1, # literal term @@ -130,33 +146,61 @@ my %arg_size = ('r' => 0, # x(0) - x register zero my %type_bit; my @tag_type; +sub define_type_bit { + my($tag,$val) = @_; + defined $type_bit{$tag} and + sanity("the tag '$tag' has already been defined with the value ", + $type_bit{$tag}); + $type_bit{$tag} = $val; +} + { my($bit) = 1; my(%bit); foreach (split('', $genop_types)) { push(@tag_type, $_); - $type_bit{$_} = $bit; + define_type_bit($_, $bit); $bit{$_} = $bit; $bit *= 2; } # Composed types. - $type_bit{'d'} = $type_bit{'x'} | $type_bit{'y'} | $type_bit{'r'}; - $type_bit{'c'} = $type_bit{'i'} | $type_bit{'a'} | $type_bit{'n'} | $type_bit{'q'}; - $type_bit{'s'} = $type_bit{'d'} | $type_bit{'i'} | $type_bit{'a'} | $type_bit{'n'}; - $type_bit{'j'} = $type_bit{'f'} | $type_bit{'p'}; + define_type_bit('d', $type_bit{'x'} | $type_bit{'y'} | $type_bit{'r'}); + 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'}); + define_type_bit('j', $type_bit{'f'} | $type_bit{'p'}); # Aliases (for matching purposes). - $type_bit{'I'} = $type_bit{'u'}; - $type_bit{'t'} = $type_bit{'u'}; - $type_bit{'A'} = $type_bit{'u'}; - $type_bit{'L'} = $type_bit{'u'}; - $type_bit{'b'} = $type_bit{'u'}; - $type_bit{'N'} = $type_bit{'u'}; - $type_bit{'U'} = $type_bit{'u'}; - $type_bit{'e'} = $type_bit{'u'}; - $type_bit{'P'} = $type_bit{'u'}; + define_type_bit('I', $type_bit{'u'}); + define_type_bit('t', $type_bit{'u'}); + define_type_bit('A', $type_bit{'u'}); + define_type_bit('L', $type_bit{'u'}); + define_type_bit('b', $type_bit{'u'}); + define_type_bit('N', $type_bit{'u'}); + define_type_bit('U', $type_bit{'u'}); + define_type_bit('e', $type_bit{'u'}); + define_type_bit('P', $type_bit{'u'}); + define_type_bit('Q', $type_bit{'u'}); +} + +# +# Sanity checks. +# + +{ + if (@tag_type > $max_genop_types) { + sanity("\$max_genop_types is $max_genop_types, ", + "but there are ", scalar(@tag_type), + " primitive tags defined\n"); + } + + foreach my $tag (@tag_type) { + sanity("tag '$tag': primitive tags must be named with lowercase letters") + unless $tag =~ /^[a-z]$/; + } } # @@ -169,6 +213,7 @@ while (@ARGV && $ARGV[0] =~ /^-(.*)/) { ($target = \&emulator_output), next if /^emulator/; ($target = \&compiler_output), next if /^compiler/; ($outdir = shift), next if /^outdir/; + ($wordsize = shift), next if /^wordsize/; ($verbose = 1), next if /^v/; die "$0: Bad option: -$_\n"; } @@ -422,12 +467,12 @@ sub emulator_output { # my(@bits) = (0) x ($max_spec_operands/2); - my($shift) = 16; my($i); for ($i = 0; $i < $max_spec_operands && defined $args[$i]; $i++) { my $t = $args[$i]; if (defined $type_bit{$t}) { - $bits[int($i/2)] |= $type_bit{$t} << (16*($i%2)); + my $shift = $max_genop_types * ($i % 2); + $bits[int($i/2)] |= $type_bit{$t} << $shift; } } @@ -474,8 +519,9 @@ sub emulator_output { $gen_transform_offset{$key} : -1; my($spec_op) = $gen_to_spec{$key}; my($num_specific) = $num_specific{$key}; - defined $spec_op or $tr != -1 or + defined $spec_op or $obsolete[$gen_opnum{$name,$arity}] or + $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}); @@ -498,8 +544,14 @@ sub emulator_output { print "#define NUM_SPECIFIC_OPS ", scalar(@op_to_name), "\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"; @@ -732,6 +784,10 @@ sub error { die $where, @message, "\n"; } +sub sanity { + die "internal error: ", @_, "\n"; +} + sub comment { my($lang, @comments) = @_; my($prefix); @@ -792,6 +848,7 @@ sub basic_generator { 'I' => 1, 't' => 1, 'P' => 1, + 'Q' => 1, ); # Pick up the macro to use and its flags (if any). @@ -813,7 +870,7 @@ sub basic_generator { # if ($flags =~ /-pack/ && $hot) { - ($prefix, $pack_spec, @args) = &do_pack(@args); + ($prefix, $pack_spec, @args) = &do_pack(@args); } # @@ -907,16 +964,27 @@ sub basic_generator { my($code); if (defined $macro{$name}) { my($macro_code) = "$prefix$macro(" . join(', ', @f) . ");"; - $var_decls .= "Uint tmp_packed1;" + $var_decls .= "BeamInstr tmp_packed1;" if $macro_code =~ /tmp_packed1/; - $var_decls .= "Uint tmp_packed2;" + $var_decls .= "BeamInstr tmp_packed2;" if $macro_code =~ /tmp_packed2/; if ($flags =~ /-nonext/) { - $code = "$macro_code\n"; + $code = join("\n", + "{ $var_decls", + $macro_code, + "}"); + } elsif ($flags =~ /-goto:(\S*)/) { + my $goto = $1; + $code = join("\n", + "{ $var_decls", + $macro_code, + "I += $size + 1;", + "goto $goto;", + "}"); } else { $code = join("\n", "{ $var_decls", - "Eterm* next;", + "BeamInstr* next;", "PreFetch($size, next);", "$macro_code", "NextPF($size, next);", @@ -931,18 +999,31 @@ sub basic_generator { sub do_pack { my(@args) = @_; - my($i); my($packable_args) = 0; + my @is_packable; # Packability (boolean) for each argument. + my $wide_packing = 0; # # Count the number of packable arguments. If we encounter any 's' or 'd' # arguments, packing is not possible. # - for ($i = 0; $i < @args; $i++) { - if ($args[$i] =~ /[xyt]/) { + my $packable_types = "xytQ"; + foreach my $arg (@args) { + if ($arg =~ /^[$packable_types]/) { $packable_args++; - } elsif ($args[$i] =~ /[sd]/) { + 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); + } else { + push @is_packable, 0; } } @@ -958,10 +1039,27 @@ sub do_pack { # beginning). my($up) = ''; # Pack commands (storing back while # moving forward). - my($args_per_word) = $packable_args < 4 ? $packable_args : 2; - my(@shift) = @{$pack_shift[$args_per_word]}; - my(@mask) = @{$pack_mask[$args_per_word]}; - my(@pack_instr) = @{$pack_instr[$args_per_word]}; + 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 @shift; + my @mask; + my @instr; + + 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]}; + } # # Now generate the packing instructions. One complication is that @@ -975,10 +1073,10 @@ sub do_pack { my($ap) = 0; # Argument number within word. my($tmpnum) = 1; # Number of temporary variable. my($expr) = ''; - for ($i = 0; $i < @args; $i++) { + for (my $i = 0; $i < @args; $i++) { my($reg) = $args[$i]; my($this_size) = $arg_size{$reg}; - if ($reg =~ /[xyt]/) { + if ($is_packable[$i]) { $this_size = 0; $did_some_packing = 1; @@ -989,7 +1087,7 @@ sub do_pack { $this_size = 1; } - $down = "$pack_instr[$ap]$down"; + $down = "$instr[$ap]$down"; my($unpack) = &make_unpack($tmpnum, $shift[$ap], $mask[$ap]); $args[$i] = "pack:$this_size:$reg" . "b($unpack)"; @@ -1099,6 +1197,10 @@ sub compile_transform { if ($obsolete[$gen_opnum{$name,$arity}]) { error("obsolete function must not be used in transformations"); } + + if ($src) { + $is_transformed{$name,$arity} = 1; + } [$name,$arity,@ops]; } @@ -1287,13 +1389,28 @@ sub tr_gen_from { my($var, $type, $type_val, $cond, $val) = @$op; if ($type ne '' && $type ne '*') { - my($types) = ''; - my($type_mask) = 0; - foreach (split('', $type)) { - $types .= "$_ "; - $type_mask |= $type_bit{$_}; + # + # The is_bif, is_not_bif, and is_func instructions have + # their own built-in type test and don't need to + # be guarded with a type test instruction. + # + unless ($cond eq 'is_bif' or + $cond eq 'is_not_bif' or + $cond eq 'is_func') { + my($types) = ''; + my($type_mask) = 0; + foreach (split('', $type)) { + $types .= "$_ "; + $type_mask |= $type_bit{$_}; + } + if ($cond ne 'is_eq') { + push(@code, &make_op($types, 'is_type', $type_mask)); + } else { + $cond = ''; + push(@code, &make_op($types, 'is_type_eq', + $type_mask, $val)); + } } - push(@code, &make_op($types, 'is_type', $type_mask)); } if ($cond eq 'is_func') { |