diff options
| -rwxr-xr-x | erts/emulator/utils/beam_makeops | 171 |
1 files changed, 114 insertions, 57 deletions
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops index bb31db7eb5..ac2b140c2a 100755 --- a/erts/emulator/utils/beam_makeops +++ b/erts/emulator/utils/beam_makeops @@ -80,7 +80,10 @@ my %gen_opnum; my %num_specific; my %gen_to_spec; my %specific_op; -my %group_size; # Group size for specific operators. + +# Information about each specific operator. Key is the print name (e.g. get_list_xxy). +# Value is a hash. +my %spec_op_info; my %gen_arity; my @gen_arity; @@ -523,6 +526,37 @@ sub emulator_output { my $key; # Loop variable. # + # Generate code and meta information for all instructions. + # + 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); + if (defined $code) { + $code = "OpCase($print_name):\n$code"; + push @generated_code, [$hotness,$code,($print_name)]; + } + + # Note: Some of the information below will be modified + # for combined instructions. + my %info = ('size' => $size, + 'pack_spec' => $pack_spec, + 'adj' => 0, + 'args' => \@args); + $spec_op_info{$print_name} = \%info; + } + } + + # + # Combine micro instruction into instruction blocks and generate + # code for them. + # + combine_micro_instructions(); + + # # Information about opcodes (beam_opcodes.c). # $name = "$outdir/beam_opcodes.c"; @@ -551,14 +585,9 @@ sub emulator_output { print "\n"; # - # Combine micro instruction into instruction blocks. - # - combine_micro_instructions(); - - # # Generate code for specific ops. # - my($spec_opnum) = 0; + my $spec_opnum = 0; print "const OpEntry opc[] = {\n"; foreach $key (sort keys %specific_op) { $gen_to_spec{$key} = $spec_opnum; @@ -576,35 +605,21 @@ sub emulator_output { # The primitive types should sort before other types. - my($sort_key) = $sign; + my $sort_key = $sign; eval "\$sort_key =~ tr/$genop_types/./"; $sort_key .= ":$sign"; - $items{$sort_key} = [$name, $hot, $sign, @args]; + my $print_name = print_name($name, @args); + $items{$sort_key} = $print_name; } # # Now call the generator for the sorted result. # - foreach (sort keys %items) { - my($name, $hot, $sign, @args) = @{$items{$_}}; + foreach my $sort_key (sort keys %items) { + my $print_name = $items{$sort_key}; + my $info = $spec_op_info{$print_name}; + my(@args) = @{$info->{'args'}}; my $arity = @args; - my($instr) = "${name}_$sign"; - $instr =~ s/_$//; - - # - # Call a generator to calculate size and generate macros - # for the emulator. - # - my($size, $code, $pack) = - basic_generator($name, 1, '', 0, undef, @args); - - # - # Save the generated $code for later. - # - if (defined $code) { - $code = "OpCase($instr):\n$code"; - push @generated_code, [$hot,$code,($instr)]; - } # # Calculate the bit mask which should be used to match this @@ -626,7 +641,6 @@ sub emulator_output { } printf "/* %3d */ ", $spec_opnum; - my $print_name = $sign ne '' ? "${name}_$sign" : $name; my $init = "{"; my $sep = ""; foreach (@bits) { @@ -634,12 +648,12 @@ sub emulator_output { $sep = ","; } $init .= "}"; - my $adj = 0; - if (defined $group_size{$print_name}) { - $adj = $size - $group_size{$print_name}; - } - init_item($print_name, $init, $involves_r, $size, $adj, $pack, $sign); - $op_to_name[$spec_opnum] = $instr; + my $adj = $info->{'adj'}; + my $size = $info->{'size'}; + my $pack_spec = $info->{'pack_spec'}; + my $sign = join '', @args; + init_item($print_name, $init, $involves_r, $size, $adj, $pack_spec, $sign); + $op_to_name[$spec_opnum] = $print_name; $spec_opnum++; } } @@ -835,6 +849,12 @@ sub emulator_output { print_code(COLD); } +sub print_name { + my($name,@args) = @_; + my $sign = join '', @args; + $sign ne '' ? "${name}_$sign" : $name; +} + sub init_item { my($sep) = ""; @@ -1108,8 +1128,7 @@ sub combine_instruction_group { my $offset = 0; my @rest = @args; my @new_subs; - my $opcase = $specific; - $opcase .= "_" . join '', @args if @args; + my $opcase = print_name($specific, @args); foreach my $s (@subs) { my $code = $c_code{$s}; my(undef,undef,@c_args) = @{$code}; @@ -1117,7 +1136,7 @@ sub combine_instruction_group { foreach (0..$#c_args) { push @first, shift @rest; } - my($size,undef) = basic_generator($s, 0, '', 0, undef, @first); + my $size = cg_combined_size($s, 0, @first); $offsets{$s} = $offset unless defined $offsets{$s} and $offsets{$s} >= $offset; $offset += $size - 1; @@ -1186,7 +1205,6 @@ sub combine_instruction_group { if ($opcase ne '') { $gcode .= "OpCase($opcase):\n"; push @opcase_labels, $opcase; - $group_size{$opcase} = $group_size + 1; } if ($num_references{$label}) { $gcode .= "$label:\n"; @@ -1204,14 +1222,19 @@ sub combine_instruction_group { $transfer_to_next .= "goto $next;\n\n"; } - my(undef,$gen_code) = - basic_generator($s, 0, $flags, $offset, - $group_size-$offset-$dec, @first); + my($gen_code) = + cg_combined_code($s, 0, $flags, $offset, + $group_size-$offset-$dec, @first); $gcode .= $gen_code . $transfer_to_next; } $offset = $order_to_offset{$slots[$i+1]} if $i < $#slots; } + foreach my $print_name (@opcase_labels) { + my $info = $spec_op_info{$print_name}; + $info->{'adj'} = $info->{'size'} - $group_size - 1; + } + ($group_hotness,"{\n$gcode\n}\n\n",@opcase_labels); } @@ -1223,12 +1246,42 @@ sub micro_label { # -# Basic implementation of instruction in emulator loop -# (assuming no packing). +# Basic code generation for one instruction. # -sub basic_generator { - my($name,$hot,$extra_comments,$offset,$group_size,@args) = @_; +sub cg_basic { + my($name,@args) = @_; + my($size,$code,$pack_spec) = code_gen($name, 1, '', 0, undef, @args); + $pack_spec = build_pack_spec($pack_spec); + ($size,$code,$pack_spec); +} + +# +# Calculate size for a micro instruction. +# + +sub cg_combined_size { + my($name,$pack,@args) = @_; + my($size) = code_gen($name, $pack, '', 0, undef, @args); + $size; +} + +# +# Generate code for a micro instruction. +# + +sub cg_combined_code { + my($size,$code,$pack_spec) = code_gen(@_); + if ($pack_spec eq '') { + ($code,'',''); + } else { + my($down,$up) = split /:/, $pack_spec; + ($code,$down,$up); + } +} + +sub code_gen { + my($name,$pack,$extra_comments,$offset,$group_size,@args) = @_; my $size = 0; my $flags = ''; my @f; @@ -1242,7 +1295,7 @@ sub basic_generator { # my $c_code_ref = $c_code{$name}; - if ($hot and defined $c_code_ref and $name ne 'catch') { + if ($pack and defined $c_code_ref and $name ne 'catch') { ($var_decls, $pack_spec, @args) = do_pack(@args); } @@ -1569,7 +1622,7 @@ sub do_pack { # # Nothing to pack unless there are at least 2 packable arguments. # - return ('', '', @args) if $packable_args < 2; + return ('', ':', @args) if $packable_args < 2; # # Determine how many arguments we should pack into each word. @@ -1644,13 +1697,12 @@ sub do_pack { # beginning). my $up = ''; # Pack commands (storing back while # moving forward). - my $did_some_packing = 0; # Nothing packed yet. # Skip an unpackable argument. my $skip_unpackable = sub { my($arg) = @_; - if ($arg_size{$arg} and $did_some_packing) { + if ($arg_size{$arg}) { # Save the argument on the pack engine's stack. my $push = 'g'; if ($type_bit{$arg} & $type_bit{'q'}) { @@ -1662,11 +1714,6 @@ sub do_pack { } $down = "$push${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. } }; @@ -1700,7 +1747,6 @@ sub do_pack { 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 = " . @@ -1731,7 +1777,7 @@ sub do_pack { $arg_num++; } - my $pack_spec = $down . $up; + my $pack_spec = "$down:$up"; return ($pack_prefix, $pack_spec, @args); } @@ -1744,6 +1790,17 @@ sub make_unpack { $e; } +sub build_pack_spec { + my $pack_spec = shift; + return '' if $pack_spec eq ''; + my($down,$up) = split /:/, $pack_spec; + while ($down =~ /[gfq]$/ and $up =~ /^p/) { + $down = substr($down, 0, -1); + $up = substr($up, 1); + } + "$down$up"; +} + sub quote { local($_) = @_; return "'$_'" if $_ eq 'try'; |