aboutsummaryrefslogtreecommitdiffstats
path: root/erts
diff options
context:
space:
mode:
Diffstat (limited to 'erts')
-rwxr-xr-xerts/emulator/utils/beam_makeops171
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';