aboutsummaryrefslogtreecommitdiffstats
path: root/erts/emulator/utils
diff options
context:
space:
mode:
Diffstat (limited to 'erts/emulator/utils')
-rwxr-xr-xerts/emulator/utils/beam_emu_vars122
-rwxr-xr-xerts/emulator/utils/beam_makeops1699
-rwxr-xr-xerts/emulator/utils/make_tables33
3 files changed, 1442 insertions, 412 deletions
diff --git a/erts/emulator/utils/beam_emu_vars b/erts/emulator/utils/beam_emu_vars
new file mode 100755
index 0000000000..c798a4dada
--- /dev/null
+++ b/erts/emulator/utils/beam_emu_vars
@@ -0,0 +1,122 @@
+#!/usr/bin/perl -w
+use strict;
+
+# Analyse beam_emu.s and try to find out the registers
+# used for the important variables in process_main().
+#
+# Works for .s files from clang or gcc. For gcc, the -fverbose-asm
+# option must be used.
+#
+# Example:
+#
+# $ beam-emu-vars -vars 'c_p E HTOP FCALLS I reg freg' beam_emu.s
+# E: %r13
+# FCALLS: %rcx:98 %rax:88 16(%rsp):50 %rdi:6
+# HTOP: %r10:382 64(%rsp):88 72(%rsp):9 24(%rsp):7 %rcx:6 %r15:6 80(%rsp):3 88(%rsp):2
+# I: %rbx
+# c_p: %rbp
+# freg: 48(%rsp):11 %rcx:8 %rdi:5 %rax:4
+# reg: %r12
+#
+# That means that E, I, c_p, reg seems to be assigned to permanent registers.
+# HTOP seems to be assigned %r10, but it is saved to a scratch location
+# before any function calls. FCALLS and freg seems to be saved in a location on
+# the stack and loaded into a register when used.
+#
+# The exit status will be 0 if all variables are assigned to registers (most of
+# the time), and 1 if one or more variables are assigned to a stack location.
+
+my $vars = 'c_p E FCALLS freg HTOP I reg';
+
+while (@ARGV and $ARGV[0] =~ /^-(.*)/) {
+ $_ = $1;
+ shift;
+ ($vars = shift), next if /^vars/;
+ die "$0: Bad option: -$_\n";
+}
+
+my @vars = split(" ", $vars);
+my %vars;
+@vars{@vars} = @vars;
+
+my $inside;
+my %count;
+
+if (@ARGV != 1) {
+ usage();
+}
+
+while (<>) {
+ if (!$inside && /[.]globl\s*_?process_main/) {
+ $inside = 1;
+ } elsif ($inside && /[.]globl/) {
+ last;
+ }
+ if ($inside) {
+ if (/##DEBUG_VALUE:\s*process_main:([A-Za-z]*)\s*<-\s*(.*)/) {
+ # clang
+ my($var,$reg) = ($1,$2);
+ next if $reg =~ /^[-\d]+$/; # Ignore if number.
+ $count{$var}->{$reg}++ if $vars{$var};
+ next;
+ }
+
+ # Parse gcc verbose arguments. Comments are marked with
+ # one '#' (clang marks its comments with two '#').
+ my($src,$dst,$comment) = /movq\s+([^#]+), ([^#]+)#(?!#)\s*(.*)/;
+ next unless $comment;
+ $dst =~ s/\s*$//;
+ my($vsrc,$vdst) = split /,/, $comment, 2;
+ $vdst =~ s/^\s//;
+ update_count(\%count, $vsrc, $src);
+ update_count(\%count, $vdst, $dst);
+ if ($vars{$vdst} and $vsrc eq '%sfp') {
+ $count{$vdst}->{$src}++;
+ }
+ }
+}
+
+my @first;
+
+OUTER:
+for my $var (sort keys %count) {
+ my $total = 0;
+
+ foreach my $reg (keys %{$count{$var}}) {
+ $total += $count{$var}->{$reg}++;
+ }
+
+ foreach my $reg (keys %{$count{$var}}) {
+ if ($count{$var}->{$reg} > 0.9*$total) {
+ print "$var: $reg\n";
+ push @first, $var;
+ next OUTER;
+ }
+ }
+
+ my @r;
+ foreach my $reg (keys %{$count{$var}}) {
+ push @r, $reg;
+ }
+ @r = sort { $count{$var}->{$b} <=> $count{$var}->{$a} } @r;
+ @r = map { "$_:$count{$var}->{$_}" } @r;
+ push @first, $r[0];
+ print "$var: ", join(' ', @r), "\n";
+}
+
+foreach (@first) {
+ exit 1 if /%rsp/;
+}
+exit 0;
+
+sub update_count {
+ my($count_ref,$var,$reg) = @_;
+ return unless $vars{$var};
+ ${${$count_ref}{$var}}{$reg}++;
+}
+
+sub usage {
+ die qq[usage: beam_emu_vars [ -vars "var1 var2..." ] <filename>.s\n\n] .
+ "The exit status is 0 if all variables are assigned to registers,\n" .
+ "and 1 if one or more variables are allocated to a stack location.\n";
+}
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops
index 0a30553f71..da994fae3e 100755
--- a/erts/emulator/utils/beam_makeops
+++ b/erts/emulator/utils/beam_makeops
@@ -19,45 +19,40 @@
# %CopyrightEnd%
#
use strict;
-use vars qw($BEAM_FORMAT_NUMBER);
+use vars qw($BEAM_FORMAT_NUMBER $GC_REGEXP);
+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;
+use constant PACK_OPT_IN_INSTR_WORD => 4;
+
+# 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;
+$GC_REGEXP = undef;
my $target = \&emulator_output;
my $outdir = "."; # Directory for output files.
my $verbose = 0;
-my $hot = 1;
+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];
-
-# Mapping from packagable arguments to number of packed arguments per
-# word. Initialized after the wordsize is known.
-
-my @args_per_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.
@@ -83,6 +78,14 @@ my %num_specific;
my %gen_to_spec;
my %specific_op;
+# The following hashes are used for error checking.
+my %print_name;
+my %specific_op_arity;
+
+# 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;
@@ -91,17 +94,22 @@ my @op_to_name;
my @obsolete;
-my %macro;
-my %macro_flags;
+# Instructions and micro instructions implemented in C.
+my %c_code; # C code block, location, arguments.
+my %c_code_used; # Used or not.
-my %hot_code;
-my %cold_code;
+# Definitions for instructions combined from micro instructions.
+my %combined_instrs;
+
+my @generated_code; # Generated code.
+my %sort_order;
my @unnumbered_generic;
my %unnumbered;
my %is_transformed;
+
#
# Pre-processor.
#
@@ -128,7 +136,10 @@ my $loader_types = "nprvlqo";
my $genop_types = $compiler_types . $loader_types;
#
-# Defines the argument types and their loaded size assuming no packing.
+# Define the operand types and their loaded size assuming no packing.
+#
+# Those are the types that can be used in the definition of a specific
+# instruction.
#
my %arg_size = ('r' => 0, # x(0) - x register zero
'x' => 1, # x(N), N > 0 - x register
@@ -138,23 +149,48 @@ my %arg_size = ('r' => 0, # x(0) - x register zero
'n' => 0, # NIL (implicit)
'c' => 1, # tagged constant (integer, atom, nil)
's' => 1, # tagged source; any of the above
+ 'S' => 1, # tagged source register (x or y)
'd' => 1, # tagged destination register (r, x, y)
'f' => 1, # failure label
'j' => 1, # either 'f' or 'p'
'e' => 1, # pointer to export entry
'L' => 0, # label
- 'I' => 1, # untagged integer
- 't' => 1, # untagged integer -- can be packed
+ 't' => 1, # untagged integer (12 bits) -- can be packed
+ 'I' => 1, # untagged integer (32 bits) -- can be packed
+ 'W' => 1, # untagged integer/pointer (one word)
'b' => 1, # pointer to bif
'A' => 1, # arity value
'P' => 1, # byte offset into tuple or stack
'Q' => 1, # like 'P', but packable
- 'h' => 1, # character
+ 'h' => 1, # character (not used)
'l' => 1, # float reg
'q' => 1, # literal term
);
#
+# Define the types that may be used in a transformation rule.
+#
+# %pattern_type defines the types that may be used in a pattern
+# on the left side.
+#
+# %construction_type defines the types that may be used when
+# constructing a new instruction on the right side (a subset of
+# the pattern types that are possible to construct).
+#
+my $pattern_types = "acdfjilnopqsuxy";
+my %pattern_type;
+@pattern_type{split("", $pattern_types)} = (1) x length($pattern_types);
+
+my %construction_type;
+foreach my $type (keys %pattern_type) {
+ $construction_type{$type} = 1
+ if index($genop_types, $type) >= 0;
+}
+foreach my $makes_no_sense ('f', 'j', 'o', 'p', 'q') {
+ delete $construction_type{$makes_no_sense};
+}
+
+#
# Generate bits.
#
my %type_bit;
@@ -186,16 +222,17 @@ sub define_type_bit {
define_type_bit('s', $type_bit{'d'} | $type_bit{'i'} |
$type_bit{'a'} | $type_bit{'n'} |
$type_bit{'q'});
+ define_type_bit('S', $type_bit{'d'});
define_type_bit('j', $type_bit{'f'} | $type_bit{'p'});
- # Aliases (for matching purposes).
- define_type_bit('I', $type_bit{'u'});
+ # Aliases of 'u'. Those specify how to load the operand and
+ # what kind of packing can be done.
define_type_bit('t', $type_bit{'u'});
+ define_type_bit('I', $type_bit{'u'});
+ define_type_bit('W', $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'});
@@ -222,6 +259,12 @@ $match_engine_ops{'TOP_fail'} = 1;
sanity("tag '$tag': primitive tags must be named with lowercase letters")
unless $tag =~ /^[a-z]$/;
}
+
+ foreach my $tag (keys %arg_size) {
+ defined $type_bit{$tag} or
+ sanity("the tag '$tag' has a size in %arg_size, " .
+ "but has no defined bit pattern");
+ }
}
#
@@ -235,32 +278,75 @@ 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";
}
+if ($wordsize == 32) {
+ $defs{'ARCH_32'} = 1;
+ $defs{'ARCH_64'} = 0;
+} 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.
#
-$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;
+ @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;
+ }
+ }
+}
+
+#
+# Add placeholders for built-in macros.
+#
+
+my %predef_macros =
+ (OPERAND_POSITION => ['Expr'],
+ IF => ['Expr','IfTrue','IfFalse'],
+ REFRESH_GEN_DEST => [],
+ );
+foreach my $name (keys %predef_macros) {
+ my @args = @{$predef_macros{$name}};
+ my $body = join(':', map { '$' . $_ } @args);
+ $c_code{$name} = [$body,"built-in macro",@args],
+ $c_code_used{$name} = 1;
}
#
# Parse the input files.
#
+my $in_c_code = '';
+my $c_code_block;
+my $c_code_loc;
+my @c_args;
+
while (<>) {
my($op_num);
+ if ($in_c_code) {
+ if (/^\}/) {
+ my $name = $in_c_code;
+ my $block = $c_code_block;
+ $in_c_code = '';
+ $block =~ s/^ //mg;
+ chomp $block;
+ $c_code{$name} = [$block,$c_code_loc,@c_args];
+ } else {
+ $c_code_block .= $_;
+ }
+ next;
+ }
chomp;
if (s/\\$//) {
$_ .= <>;
@@ -268,6 +354,7 @@ while (<>) {
}
next if /^\s*$/;
next if /^\#/;
+ next if m@^//@;
#
# Handle %if.
@@ -310,36 +397,24 @@ while (<>) {
#
if (/^([\w_][\w\d_]+)=(.*)/) {
no strict 'refs';
- my($name) = $1;
- $$name = $2;
+ my $name = $1;
+ my $value = $2;
+ $value =~ s/;\s*$//;
+ $$name = $value;
next;
}
#
- # Handle %hot/%cold.
+ # Handle %hot, %warm, and %cold.
#
if (/^\%hot/) {
- $hot = 1;
+ $hotness = HOT;
next;
+ } elsif (/^\%warm/) {
+ $hotness = WARM;
+ next;
} elsif (/^\%cold/) {
- $hot = 0;
- next;
- }
-
- #
- # Handle macro definitions.
- #
- if (/^\%macro:(.*)/) {
- my($op, $macro, @flags) = split(' ', $1);
- defined($macro) and $macro =~ /^-/ and
- error("A macro must not start with a hyphen");
- foreach (@flags) {
- /^-/ or error("Flags for macros should start with a hyphen");
- }
- error("Macro for '$op' is already defined")
- if defined $macro{$op};
- $macro{$op} = $macro;
- $macro_flags{$op} = join('', @flags);
+ $hotness = COLD;
next;
}
@@ -352,6 +427,31 @@ while (<>) {
}
#
+ # Handle C code blocks.
+ #
+ if (/^(\w[\w.]*)\(([^\)]*)\)\s*{/) {
+ my $name = $1;
+ $in_c_code = $name;
+ $c_code_block = '';
+ @c_args = parse_c_args($2);
+ $c_code_loc = "$ARGV($.)";
+ if (defined $c_code{$name}) {
+ my $where = $c_code{$name}->[1];
+ error("$name: already defined at $where");
+ }
+ next;
+ }
+
+ #
+ # Handle definition of instructions in terms of
+ # micro instructions.
+ #
+ if (/^(\w+)\s*:=\s*([\w.]+)\s*;\s*$/) {
+ $combined_instrs{$1} = ["$ARGV($.)",$2];
+ next;
+ }
+
+ #
# Parse off the number of the operation.
#
$op_num = undef;
@@ -394,15 +494,7 @@ while (<>) {
# Parse specific instructions (only present in emulator/loader):
# Name Arg1 Arg2...
#
- my($name, @args) = split;
- error("too many operands")
- if @args > $max_spec_operands;
- syntax_check($name, @args);
- my $arity = @args;
- if (defined $gen_opnum{$name,$arity} and $obsolete[$gen_opnum{$name,$arity}]) {
- error("specific instructions may not be specified for obsolete instructions");
- }
- save_specific_ops($name, $arity, $hot, @args);
+ my($name,$arity) = parse_specific_op($_);
if (defined $op_num) {
error("specific instructions must not be numbered");
} elsif (!defined($gen_arity{$name}) && !defined($unnumbered{$name,$arity})) {
@@ -449,6 +541,18 @@ $num_file_opcodes = @gen_opname;
&$target();
#
+# Ensure that all C code implementations have been used.
+#
+{
+ my(@unused) = grep(!$c_code_used{$_}, keys %c_code);
+ foreach my $unused (@unused) {
+ my(undef,$where) = @{$c_code{$unused}};
+ warn "$where: $unused is unused\n";
+ }
+ die "\n" if @unused;
+}
+
+#
# Produce output needed by the emulator/loader.
#
@@ -458,6 +562,36 @@ 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 $print_name = print_name($name, @args);
+
+ my($size, $code, $pack_spec) = cg_basic(name => $name, args => \@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";
@@ -488,7 +622,7 @@ sub emulator_output {
#
# 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;
@@ -503,40 +637,26 @@ sub emulator_output {
foreach (@{$specific_op{$key}}) {
my($name, $hot, @args) = @{$_};
my($sign) = join('', @args);
+ $sign =~ s/[?]//g;
# 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'}};
+ @args = map { s/[?]$//; $_ } @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, $hot, @args);
-
- #
- # Save the generated $code for later.
- #
- if (defined $code) {
- if ($hot) {
- push(@{$hot_code{$code}}, $instr);
- } else {
- push(@{$cold_code{$code}}, $instr);
- }
- }
#
# Calculate the bit mask which should be used to match this
@@ -558,7 +678,6 @@ sub emulator_output {
}
printf "/* %3d */ ", $spec_opnum;
- my $print_name = $sign ne '' ? "${name}_$sign" : $name;
my $init = "{";
my $sep = "";
foreach (@bits) {
@@ -566,8 +685,12 @@ sub emulator_output {
$sep = ",";
}
$init .= "}";
- init_item($print_name, $init, $involves_r, $size, $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++;
}
}
@@ -646,12 +769,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";
- print "#define BEAM_WIDE_MASK 0xFFFFUL\n";
- print "#define BEAM_LOOSE_MASK 0xFFFFUL\n";
- print "#define BEAM_TIGHT_MASK 0xFFFFUL\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";
@@ -750,13 +880,24 @@ sub emulator_output {
$name = "$outdir/beam_hot.h";
open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
comment('C');
- print_code(\%hot_code);
+ print_code(HOT);
+
+ $name = "$outdir/beam_warm.h";
+ open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
+ comment('C');
+ print_code(WARM);
$name = "$outdir/beam_cold.h";
open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
comment('C');
- print_code(\%cold_code);
+ print_code(COLD);
+}
+sub print_name {
+ my($name,@args) = @_;
+ my $sign = join '', @args;
+ $sign =~ s/[?]//g;
+ $sign ne '' ? "${name}_$sign" : $name;
}
sub init_item {
@@ -784,29 +925,47 @@ sub q {
}
sub print_code {
- my($ref) = @_;
- my(%sorted);
- my($key, $label); # Loop variables.
-
- foreach $key (keys %$ref) {
- my($sort_key);
- my($code) = '';
- foreach $label (@{$ref->{$key}}) {
- $code .= "OpCase($label):\n";
- $sort_key = $label;
- }
- foreach (split("\n", $key)) {
- $code .= " $_\n";
- }
- $code .= "\n";
- $sorted{$sort_key} = $code;
+ my($include_hot) = @_;
+ my %sorted;
+
+ foreach my $ref (@generated_code) {
+ my($hot,$code,@labels) = @$ref;
+ next unless $hot == $include_hot;
+ my($sort_key) = @labels; # Use the first label as sort key.
+ $sorted{$sort_key} = $code;
}
foreach (sort keys %sorted) {
- print $sorted{$_};
+ print_indented_code($sorted{$_});
}
}
+sub print_indented_code {
+ my(@code) = @_;
+
+ foreach my $chunk (@code) {
+ my $indent = 0;
+ foreach (split "\n", $chunk) {
+ s/^\s*//;
+ if (/\}/) {
+ $indent -= 2;
+ }
+ if ($_ eq '') {
+ print "\n";
+ } elsif (/^#/) {
+ print $_, "\n";
+ } else {
+ print ' ' x $indent, $_, "\n";
+ }
+ if (/\{/) {
+ $indent += 2;
+ }
+ }
+ print "\n";
+ }
+}
+
+
#
# Produce output needed by the compiler back-end (assembler).
#
@@ -857,40 +1016,82 @@ sub compiler_output {
}
#
-# Check an operation for validity.
+# Parse and store a specific operation.
#
-sub syntax_check {
- my($name, @args) = @_;
- my($i);
+sub parse_specific_op {
+ my($name, @args) = split " ", shift;
+ my $arity = @args;
+ # Check for various errors.
error("Bad opcode name '$name'")
unless $name =~ /^[a-z][\w\d_]*$/;
- for ($i = 0; $i < @args; $i++) {
- foreach my $type (split(//, $args[$i])) {
+ error("too many operands")
+ if @args > $max_spec_operands;
+ for (my $i = 0; $i < $arity; $i++) {
+ my $arg = $args[$i];
+ $arg =~ s/[?]$//;
+ foreach my $type (split(//, $arg)) {
error("Argument " . ($i+1) . ": invalid type '$type'")
unless defined $arg_size{$type};
}
}
-}
-
-sub save_specific_ops {
- my($name,$arity,$hot,@args) = @_;
- my(@res) = ("");
+ if (defined $gen_opnum{$name,$arity} and $obsolete[$gen_opnum{$name,$arity}]) {
+ error("specific instructions may not be specified for obsolete instructions");
+ }
+ # Expand operands with multiple types to multiple instructions.
+ # (For example, "get_list xy xy xy" will be expanded to six instructions.)
+ my @res = ([]);
foreach my $arg (@args) {
- my @new_res = ();
+ my @old_res = @res;
+ @res = ();
+ my $marker = ($arg =~ s/[?]$//) ? '?' : '';
foreach my $type (split(//, $arg)) {
- foreach my $args (@res) {
- push @new_res, "$args$type";
+ foreach my $args_ref (@old_res) {
+ my @args = @$args_ref;
+ push @args, "$type$marker";
+ push @res, \@args;
}
}
- @res = @new_res;
}
+
+ # Store each specific instruction.
my $key = "$name/$arity";
- foreach my $args (@res) {
- @args = split //, $args;
- push @{$specific_op{$key}}, [$name,$hot,@args];
+ foreach my $args_ref (@res) {
+ @args = @$args_ref;
+ my $arity = @args;
+ my $loc = "$ARGV($.)";
+ if (defined $specific_op_arity{$name}) {
+ my($prev_arity,$loc) = @{$specific_op_arity{$name}};
+ if ($arity != $prev_arity) {
+ error("$name defined with arity $arity, " .
+ "but previously defined with arity $prev_arity at $loc");
+ }
+ }
+ $specific_op_arity{$name} = [$arity,$loc];
+ my $print_name = print_name($name, @args);
+ if (defined $print_name{$print_name}) {
+ error("$name @args: already defined at " .
+ $print_name{$print_name});
+ }
+ $print_name{$print_name} = $loc;
+ push @{$specific_op{$key}}, [$name,$hotness,@args];
+ }
+
+ # Done.
+ ($name,$arity);
+}
+
+sub parse_c_args {
+ local($_) = @_;
+ my @res;
+
+ while (s/^(\w[\w\d]*)\s*//) {
+ push @res, $1;
+ s/^,\s*// or last;
}
+ $_ eq '' or error("garbage in argument list: $_");
+ @res;
}
sub error {
@@ -934,58 +1135,314 @@ sub comment {
}
#
-# Basic implementation of instruction in emulator loop
-# (assuming no packing).
+# Combine micro instruction into instruction blocks.
#
+sub combine_micro_instructions {
+ my %groups;
+
+ # Sanity check, normalize micro instructions.
+ foreach my $instr (keys %combined_instrs) {
+ my $ref = $combined_instrs{$instr};
+ my($def_loc,$def) = @$ref;
+ my($group,@subs) = split /[.]/, $def;
+ my $arity = 0;
+ @subs = map { "$group.$_" } @subs;
+ foreach my $s (@subs) {
+ my $code = $c_code{$s};
+ defined $code or
+ error("$def_loc: no definition of $s");
+ $c_code_used{$s} = 1;
+ my(undef,undef,@c_args) = @{$code};
+ $arity += scalar(@c_args);
+ }
+ push @{$groups{$group}}, [$instr,$arity,@subs];
+ }
-sub basic_generator {
- my($name, $hot, @args) = @_;
- my($size) = 0;
- my($macro) = '';
- my($flags) = '';
- my(@f);
- my(@f_types);
- my($fail_type);
- my($prefix) = '';
- my($tmp_arg_num) = 1;
- my($pack_spec) = '';
- my($var_decls) = '';
- my($i);
- my($no_prefetch) = 0;
+ # Now generate code for each group.
+ foreach my $group (sort keys %groups) {
+ my($hotness,$code,@labels) =
+ combine_instruction_group($group, @{$groups{$group}});
+ push @generated_code, [$hotness,$code,@labels];
+ }
+}
- # The following argument types should be included as macro arguments.
- my(%incl_arg) = ('c' => 1,
- 'i' => 1,
- 'a' => 1,
- 'A' => 1,
- 'N' => 1,
- 'U' => 1,
- 'I' => 1,
- 't' => 1,
- 'P' => 1,
- 'Q' => 1,
- );
+sub combine_instruction_group {
+ my($group,@in_instrs) = @_;
+ my $gcode = ''; # Code for the entire group.
+ my $group_hotness = COLD;
- # Pick up the macro to use and its flags (if any).
+ # Get code for the head of the group (if any).
+ my $head_name = "$group.head";
+ $c_code_used{$head_name} = 1;
+ my $head_code_ref = $c_code{$head_name};
+ if (defined $head_code_ref) {
+ my($head_code,$where,@c_args) = @{$head_code_ref};
+ @c_args and error("$where: no arguments allowed for " .
+ "head function '$head_name()'");
+ $gcode = $head_code . "\n";
+ }
- $macro = $macro{$name} if defined $macro{$name};
- $flags = $macro_flags{$name} if defined $macro_flags{$name};
+ # Variables.
+ my %offsets;
+ my @instrs;
+ my %num_references; # Number of references from other sub instructions.
+ my $group_size = 999;
#
- # Add any arguments to be included as macro arguments (for instance,
- # 'p' is usually not an argument, except for calls).
+ # Calculate the number of references from other sub instructions.
+ # This number is useful in several ways:
+ #
+ # * If this number is 0, it is only used as the entry point for a
+ # function, implying that it does not need a label and that operands
+ # can be packed into the instruction word.
+ #
+ # * We'll use this number in the sort key, as a tie breaker for sub instructions
+ # at the same instruction offset.
#
+ foreach my $ref_instr (@in_instrs) {
+ my(undef,undef,$first_sub,@other_subs) = @$ref_instr;
+ $num_references{$first_sub} += 0; # Make sure it is defined.
+ foreach my $sub (@other_subs) {
+ $num_references{$sub}++;
+ }
+ }
- while ($flags =~ /-arg_(\w)/g) {
- $incl_arg{$1} = 1;
- };
+ # Do basic error checking. Associate operands of instructions
+ # with the correct micro instructions. Calculate offsets for micro
+ # instructions.
+ foreach my $ref_instr (@in_instrs) {
+ my($specific,$arity,@subs) = @$ref_instr;
+ my $specific_key = "$specific/$arity";
+ my $specific_op_ref = $specific_op{$specific_key};
+ error("no $specific_key instruction")
+ unless defined $specific_op_ref;
+ foreach my $specific_op (@$specific_op_ref) {
+ my($name, $hotness, @args) = @{$specific_op};
+ $group_hotness = $hotness unless $group_hotness >= $hotness;
+ my $offset = 0;
+ my @rest = @args;
+ my @new_subs;
+ my $print_name = print_name($specific, @args);
+ my $opcase = $print_name;
+ my $last = $subs[$#subs];
+ foreach my $s (@subs) {
+ my $code = $c_code{$s};
+ my(undef,undef,@c_args) = @{$code};
+ my @first;
+ foreach (0..$#c_args) {
+ push @first, shift @rest;
+ }
+ my $size = cg_combined_size(name => $s,
+ first => $num_references{$s} == 0,
+ args => \@first);
+ $offsets{$s} = $offset
+ unless defined $offsets{$s} and $offsets{$s} < $offset;
+ $offset += $size - 1;
+ my $label = micro_label($s);
+ push @new_subs, [$opcase,$label,$s,$size-1,@first];
+ $opcase = '';
+ }
+ $spec_op_info{$print_name}->{'size'} = $offset + 1;
+ $group_size = $offset if $group_size >= $offset;
+ push @instrs, [$specific_key,@new_subs];
+ }
+ }
+
+ # Link the sub instructions for each instructions to each
+ # other.
+ my @all_instrs;
+ foreach my $instr (@instrs) {
+ my($specific_key,@subs) = @{$instr};
+ for (my $i = 0; $i < @subs; $i++) {
+ my($opcase,$label,$s,$size,@args) = @{$subs[$i]};
+ my $next = '';
+ (undef,$next) = @{$subs[$i+1]} if $i < $#subs;
+ my $instr_info = "$opcase:$label:$next:$s:$size:@args";
+ push @all_instrs, [$label,$s,$offsets{$s},$instr_info];
+ }
+ }
+
+ my %order_to_instrs;
+ my %label_to_offset;
+ my %order_to_offset;
+ foreach my $instr (@all_instrs) {
+ my($label,$s,$offset,$instr_info) = @$instr;
+ my $sort_key = sprintf("%02d.%02d", $offset, $num_references{$s});
+ push @{$order_to_instrs{$sort_key}}, $instr_info;
+ $label_to_offset{$label} = $offset;
+ $order_to_offset{$sort_key} = $offset;
+ }
+
+ my(@slots) = sort {$a <=> $b} keys %order_to_instrs;
+
+ # Now generate the code for the entire group.
+ my $offset = 0;
+ my @opcase_labels;
+ my %down;
+ my %up;
+ for(my $i = 0; $i < @slots; $i++) {
+ my $key = $slots[$i];
+
+ # Sort micro-instructions with OpCase before other micro-instructions.
+ my(@instrs) = @{$order_to_instrs{$key}};
+ my $order_func = sub {
+ my $a_key = ($a =~ /^:/) ? "1$a" : "0$a";
+ my $b_key = ($b =~ /^:/) ? "1$b" : "0$b";
+ $a_key cmp $b_key;
+ };
+ @instrs = sort $order_func @instrs;
+
+ my %seen;
+ foreach my $instr (@instrs) {
+ my($opcase,$label,$next,$s,$size,$args) = split ":", $instr;
+ my(@first) = split " ", $args;
+
+ my $seen_key = "$label:$next:" . scalar(@first);
+ next if $opcase eq '' and $seen{$seen_key};
+ $seen{$seen_key} = 1;
+ $seen_key .= $opcase;
+
+ if ($opcase ne '') {
+ $gcode .= "OpCase($opcase):\n";
+ push @opcase_labels, $opcase;
+ }
+ if ($num_references{$s}) {
+ $gcode .= "$label:\n";
+ }
+
+ my $flags = '';
+ my $transfer_to_next = '';
+ my $inc = 0;
+
+ unless ($i == $#slots) {
+ $flags = "-no_next";
+ my $next_offset = $label_to_offset{$next};
+ $inc = ($offset + $size) - $next_offset;
+ $transfer_to_next = "I += $inc;\n" if $inc;
+ $transfer_to_next .= "goto $next;\n\n";
+ }
+
+ my($gen_code,$down,$up) =
+ cg_combined_code(name => $s,
+ first => $num_references{$s} == 0,
+ extra_comments => $flags,
+ offset => $offset,
+ comp_size => $group_size-$offset,
+ inc => $inc,
+ args =>\@first);
+ my $spec_label = "$opcase$label";
+ $down{$spec_label} = $down;
+ $up{$spec_label} = $up;
+ $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;
+ }
#
- # Pack arguments if requested.
+ # Assemble pack specifications for all instructions in the group.
#
+ foreach my $instr (@instrs) {
+ my(undef,@subs) = @{$instr};
+ my $down = '';
+ my $up = '';
+ for (my $i = 0; $i < @subs; $i++) {
+ my($opcase,$label) = @{$subs[$i]};
+ my $spec_label = "$opcase$label";
+ if (defined $down{$spec_label}) {
+ $down = $down{$spec_label} . $down;
+ $up = $up . $up{$spec_label};
+ }
+ }
+ my $print_name = $subs[0]->[0];
+ my $info = $spec_op_info{$print_name};
+ $info->{'pack_spec'} = build_pack_spec("$down:$up");
+ }
+
+ ($group_hotness,"{\n$gcode\n}\n\n",@opcase_labels);
+}
+
+sub micro_label {
+ my $label = shift;
+ $label =~ s/[.]/__/g;
+ $label;
+}
- if ($flags =~ /-pack/ && $hot) {
- ($prefix, $pack_spec, @args) = do_pack(@args);
+
+#
+# Basic code generation for one instruction.
+#
+
+sub cg_basic {
+ my %params = (@_, pack_options => \@extended_pack_options);
+ my($size,$code,$pack_spec) = code_gen(%params);
+ $pack_spec = build_pack_spec($pack_spec);
+ ($size,$code,$pack_spec);
+}
+
+#
+# Calculate size for a micro instruction.
+#
+
+sub cg_combined_size {
+ my %params = (@_,
+ pack_options => \@basic_pack_options,
+ size_only => 1);
+ $params{pack_options} = \@extended_pack_options
+ if $params{first};
+ my($size) = code_gen(%params);
+ $size;
+}
+
+#
+# Generate code for a micro instruction.
+#
+
+sub cg_combined_code {
+ my %params = (@_, pack_options => \@basic_pack_options);
+ $params{pack_options} = \@extended_pack_options
+ if $params{first};
+ my($size,$code,$pack_spec) = code_gen(%params);
+ if ($pack_spec eq '') {
+ ($code,'','');
+ } else {
+ my($down,$up) = split /:/, $pack_spec;
+ ($code,$down,$up);
+ }
+}
+
+sub code_gen {
+ my %params = (extra_comments => '',
+ offset => 0,
+ inc => 0,
+ size_only => 0,
+ @_);
+ my $name = $params{name};
+ my $extra_comments = $params{extra_comments};
+ my $offset = $params{offset};
+ my $inc = $params{inc};
+ my @args = @{$params{args}};
+
+ my $size = 0;
+ my $flags = '';
+ my @f;
+ my $prefix = '';
+ my $tmp_arg_num = 1;
+ my $pack_spec = '';
+ my $var_decls = '';
+
+ #
+ # Pack arguments for hot code with an implementation.
+ #
+
+ my $c_code_ref = $c_code{$name};
+ if (defined $c_code_ref and $name ne 'catch') {
+ my $pack_options = $params{pack_options};
+ ($var_decls, $pack_spec, @args) = do_pack($name, $offset, $pack_options, @args);
}
#
@@ -993,259 +1450,696 @@ sub basic_generator {
# the macro.
#
+ my $need_block = 0;
+ my $arg_offset = $offset;
+ my $has_gen_dest = 0;
+ @args = map { s/[?]$//g; $_ } @args;
foreach (@args) {
my($this_size) = $arg_size{$_};
SWITCH:
{
- /^pack:(\d):(.*)/ and do { push(@f, $2);
- push(@f_types, 'packed');
- $this_size = $1;
- last SWITCH;
- };
- /r/ and do { push(@f, "r(0)"); push(@f_types, $_); last SWITCH };
- /[xy]/ and do { push(@f, "$_" . "b(Arg($size))");
- push(@f_types, $_);
- last SWITCH;
- };
- /n/ and do { push(@f, "NIL"); push(@f_types, $_); last SWITCH };
- /s/ and do { my($tmp) = "targ$tmp_arg_num";
- $var_decls .= "Eterm $tmp; ";
- $tmp_arg_num++;
- push(@f, $tmp);
- push(@f_types, $_);
- $prefix .= "GetR($size, $tmp);\n";
- last SWITCH; };
- /d/ and do { $var_decls .= "Eterm dst; Eterm* dst_ptr; ";
- push(@f, "*dst_ptr");
- push(@f_types, $_);
- $prefix .= "dst = Arg($size);\n";
- $prefix .= "dst_ptr = REG_TARGET_PTR(dst);\n";
- last SWITCH;
- };
- defined($incl_arg{$_})
- and do { push(@f, "Arg($size)");
- push(@f_types, $_);
- last SWITCH;
- };
-
- /[fp]/ and do { $fail_type = $_; last SWITCH };
-
- /[eLIFEbASjPowlq]/ and do { last SWITCH; };
+ /^packed:d:(\d):(.*)/ and do {
+ $var_decls .= "Eterm dst = $2;\n" .
+ "Eterm* dst_ptr = REG_TARGET_PTR(dst);\n";
+ push(@f, "*dst_ptr");
+ $this_size = $1;
+ $has_gen_dest = 1;
+ last SWITCH;
+ };
+ /^packed:[a-zA-z]:(\d):(.*)/ and do {
+ push(@f, $2);
+ $this_size = $1;
+ last SWITCH;
+ };
+ /r/ and do {
+ push(@f, "r(0)");
+ last SWITCH;
+ };
+ /[lxyS]/ and do {
+ push(@f, $_ . "b(" . arg_offset($arg_offset) . ")");
+ last SWITCH;
+ };
+ /n/ and do {
+ push(@f, "NIL");
+ last SWITCH;
+ };
+ /s/ and do {
+ my($tmp) = "targ$tmp_arg_num";
+ $var_decls .= "Eterm $tmp;\n";
+ $tmp_arg_num++;
+ push(@f, $tmp);
+ $prefix .= "GetR($arg_offset, $tmp);\n";
+ $need_block = 1;
+ last SWITCH;
+ };
+ /d/ and do {
+ $var_decls .= "Eterm dst = " . arg_offset($arg_offset) . ";\n" .
+ "Eterm* dst_ptr = REG_TARGET_PTR(dst);\n";
+ push(@f, "*dst_ptr");
+ $has_gen_dest = 1;
+ last SWITCH;
+ };
+ defined $arg_size{$_} and do {
+ push @f, arg_offset($arg_offset);
+ last SWITCH;
+ };
die "$name: The generator can't handle $_, at";
}
$size += $this_size;
+ $arg_offset += $this_size;
}
#
- # Add a fail action macro if requested.
+ # If the implementation is in beam_emu.c or if
+ # the caller only wants the size, we are done.
#
+ if (not defined $c_code_ref or $params{size_only}) {
+ return ($size+1, undef, '');
+ }
- $flags =~ /-fail_action/ and do {
- $no_prefetch = 1;
- if (!defined $fail_type) {
- my($i);
- for ($i = 0; $i < @f_types; $i++) {
- local($_) = $f_types[$i];
- /[rxycians]/ and do { push(@f, "Badmatch($f[$i])"); next };
- }
- } elsif ($fail_type eq 'f') {
- push(@f, "ClauseFail()");
- } else {
- my($i);
- for ($i = 0; $i < @f_types; $i++) {
- local($_) = $f_types[$i];
- /[rxycians]/ and do { push(@f, "Badmatch($f[$i])"); next };
- }
- }
- };
+ my $group_size = ($params{comp_size} || $size) + $inc;
#
- # Add a size argument if requested.
+ # Generate main body of the implementation.
#
+ my($c_code,$where,@c_args) = @{$c_code_ref};
+ my %bindings;
+ $c_code_used{$name} = 1;
- $flags =~ /-size/ and do {
- push(@f, $size);
- };
+ if (@f != @c_args) {
+ error("$where: defining '$name' with ", scalar(@c_args),
+ " arguments instead of expected ", scalar(@f), " arguments");
+ }
- # Generate the macro if requested.
- my($code);
- if (defined $macro{$name}) {
- my($macro_code) = "$prefix$macro(" . join(', ', @f) . ");";
- $var_decls .= "BeamInstr tmp_packed1;"
- if $macro_code =~ /tmp_packed1/;
- $var_decls .= "BeamInstr tmp_packed2;"
- if $macro_code =~ /tmp_packed2/;
- if ($flags =~ /-nonext/) {
- $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;",
- "}");
- } elsif ($no_prefetch) {
- $code = join("\n",
- "{ $var_decls",
- $macro_code,
- "Next($size);",
- "}", "");
- } else {
- $code = join("\n",
- "{ $var_decls",
- "BeamInstr* next;",
- "PreFetch($size, next);",
- "$macro_code",
- "NextPF($size, next);",
- "}", "");
- }
+ for (my $i = 0; $i < @f; $i++) {
+ my $var = $c_args[$i];
+ $bindings{$var} = $f[$i];
+ }
+ $bindings{'NEXT_INSTRUCTION'} = "I+" . ($group_size+$offset+1);
+ $bindings{'IP_ADJUSTMENT'} = $inc;
+ $c_code = eval { expand_all($c_code, \%bindings) };
+ unless (defined $c_code) {
+ warn $@;
+ error("... from the body of $name at $where");
+ }
+ my(@comments) = $c_code =~ m@//[|]\s*(.*)@g;
+ $c_code =~ s@//[|]\s*(.*)\n?@@g;
+ $flags = "@comments $extra_comments";
+
+ #
+ # Generate code for transferring to the next instruction.
+ #
+ my $dispatch_next;
+ my $instr_offset = $group_size + $offset + 1;
+
+ if ($flags =~ /-no_next/) {
+ $dispatch_next = "";
+ } elsif ($flags =~ /-no_prefetch/) {
+ $dispatch_next = "\nI += $instr_offset;\n" .
+ "ASSERT(VALID_INSTR(*I));\n" .
+ "Goto(*I);";
+ } else {
+ $var_decls .= "BeamInstr next_pf = BeamCodeAddr(I[$instr_offset]);\n";
+ $dispatch_next = "\nI += $instr_offset;\n" .
+ "ASSERT(VALID_INSTR(next_pf));\n" .
+ "GotoPF(next_pf);";
+ }
+
+ #
+ # Assemble the complete code for the instruction.
+ #
+ my $body = "$c_code$dispatch_next";
+ if ($need_block) {
+ $body = "$prefix\{\n$body\n}";
+ } else {
+ $body = "$prefix$body";
+ }
+ my $code = join("\n",
+ "{",
+ "$var_decls$body",
+ "}", "");
+
+ # Make sure that $REFRESH_GEN_DEST() is used when a
+ # general destination ('d') may have been clobbered by
+ # a GC.
+ my $gc_error = verify_gc_code($code, $has_gen_dest);
+ if (defined $gc_error) {
+ warn $gc_error;
+ error("... from the body of $name at $where");
+ }
+
+ # Done.
+ ($size+1, $code, $pack_spec);
+}
+
+sub verify_gc_code {
+ my $code = shift;
+ my $has_gen_dest = shift;
+
+ return unless $has_gen_dest;
+
+ if ($code =~ /$GC_REGEXP/o) {
+ my $code_after_gc = substr($code, $+[0]);
+ unless ($code_after_gc =~ /dst_ptr = REG_TARGET_PTR/) {
+ return "pointer to destination register is invalid after GC -- " .
+ "use \$REFRESH_GEN_DEST()\n";
+ }
+ }
+ return undef;
+}
+
+sub arg_offset {
+ my $offset = shift;
+ "I[" . ($offset+1) . "]";
+}
+
+sub expand_all {
+ my($code,$bindings_ref) = @_;
+ my %bindings = %{$bindings_ref};
+
+ # Expand all $Var occurrences.
+ $code =~ s/[\$](\w[\w\d]*)(?!\()/defined $bindings{$1} ? $bindings{$1} : "\$$1"/ge;
+
+ # Find calls to macros, $name(...), and expand them.
+ my $res = "";
+ while ($code =~ /[\$](\w[\w\d]*)\(/) {
+ my $macro_name = $1;
+ my $keep = substr($code, 0, $-[0]);
+ my $after = substr($code, $+[0]);
+
+ my $body;
+ ($body,$code) = expand_macro($macro_name, $after, \%bindings);
+ $res .= "$keep$body";
+ }
+
+ $res . $code;
+}
+
+sub expand_macro {
+ my($name,$rest,$bindings_ref) = @_;
+
+ my $c_code = $c_code{$name};
+ defined $c_code or
+ error("calling undefined macro '$name'...");
+ $c_code_used{$name} = 1;
+ my ($body,$where,@vars) = @{$c_code};
+
+ # Separate the arguments into @args;
+ my @args;
+ my $level = 1;
+ my %inc = ('(' => 1, ')' => -1,
+ '[' => 1, ']' => -1,
+ '{' => 1, '}' => -1);
+ my $arg = undef;
+ while ($rest =~ /([,\(\[\{\}\]\)]|([^,\(\[\{\}\]\)]*))/g) {
+ my $token = $1;
+ my $inc = $inc{$token} || 0;
+ $level += $inc;
+ if ($level == 0) {
+ $rest = substr($rest, pos($rest));
+ push @args, $arg if defined $arg;
+ last;
+ }
+ if ($token eq ',') {
+ if ($level == 1) {
+ push @args, $arg;
+ $arg = "";
+ }
+ next;
+ }
+ $arg .= $token;
+ }
+
+ # Trim leading whitespace from each argument.
+ foreach my $arg (@args) {
+ $arg =~ s/^\s*//;
+ }
+
+ # Make sure that the number of arguments are correct.
+ if (@vars != @args) {
+ error("calling $name with ", scalar(@args),
+ " arguments instead of expected ", scalar(@vars), " arguments...");
+ }
+
+ # Now combine bindings from the parameter names and arguments.
+ my %bindings = %{$bindings_ref};
+ my %new_bindings;
+
+ # Keep the special, pre-defined bindings.
+ foreach my $key (qw(NEXT_INSTRUCTION IP_ADJUSTMENT)) {
+ $new_bindings{$key} = $bindings{$key};
+ }
+
+ for (my $i = 0; $i < @vars; $i++) {
+ my $arg = $args[$i];
+ $arg = eval { expand_all($arg, \%bindings) };
+ unless (defined $arg) {
+ warn $@;
+ die "... from the body of $name at $where\n";
+ }
+ $new_bindings{$vars[$i]} = $arg;
+ }
+
+ $body = eval { expand_all($body, \%new_bindings) };
+ unless (defined $body) {
+ warn $@;
+ die "... from the body of $name at $where\n";
+ }
+
+ # Handle built-in macros.
+ if ($name eq 'OPERAND_POSITION') {
+ if ($body =~ /^I\[(\d+)\]$/) {
+ $body = $1;
+ } else {
+ $body = 0;
+ }
+ } elsif ($name eq 'IF') {
+ my $expr = $new_bindings{Expr};
+ my $bool = eval $expr;
+ if ($@ ne '') {
+ &error("bad expression '$expr' in \$IF()");
+ }
+ my $part = $bool ? 'IfTrue' : 'IfFalse';
+ $body = $new_bindings{$part};
+ } elsif ($name eq 'REFRESH_GEN_DEST') {
+ $body = "dst_ptr = REG_TARGET_PTR(dst)";
}
- # Return the size and code for the macro (if any).
- $size++;
- ($size, $code, $pack_spec);
+
+ # Wrap body if needed and return result.
+ $body = "do {\n$body\n} while (0)"
+ if needs_do_wrapper($body);
+ ($body,$rest);
+}
+
+# Conservative heuristic to determine whether a do { ... } while(0)
+# wrapper is needed.
+sub needs_do_wrapper {
+ local $_ = shift;
+
+ s@^//[|][^\n]*\n@@;
+ s@^\s*@@s;
+ s@^/[*].*[*]/\s*@@s;
+ return 1 if /^(Eterm|Uint|Sint|int|unsigned)/; # Definitely needed.
+ return 0 if /^do/;
+ return 0 if /^SET_I/;
+ return 0 if /^SET_CP/;
+ return 0 if /^ERTS_NO_FPE_CHECK_INIT/;
+ return 0 if /^ASSERT/;
+ return 0 if /^DTRACE/;
+ return 0 if /^[A-Za-z_]*\s*=/;
+ return 0 if /^c_p->/;
+ return 0 if /^[A-Z_]*SWAPOUT/;
+ return 0 if /^if\s*[(]/;
+ return 0 if /^goto\b/;
+ return 0 if /^\d+/;
+ return 1; # Not sure, say that it is needed.
}
sub do_pack {
- my(@args) = @_;
+ my($name,$offset,$pack_opts_ref,@args) = @_;
+ my @pack_opts = @$pack_opts_ref;
+ my $opt_arg_pos = -1;
+
+ # Look for an optional use operand not as the first argument.
+ if (@args and $args[0] !~ /[?]$/) {
+ for (my $pos = 0; $pos < @args; $pos++) {
+ if ($args[$pos] =~ /[?]$/) {
+ $opt_arg_pos = $pos;
+ last;
+ }
+ }
+ }
+
+ @args = map { s/[?]$//; $_ } @args; # Remove any optional use marker.
+
+ # If there is an optional operand, extend the array of pack options.
+ if ($opt_arg_pos >= 0) {
+ my @new_pack_opts = grep { $_ & PACK_IN_INSTR_WORD } @pack_opts;
+ @new_pack_opts = map {
+ ($_ & ~ PACK_IN_INSTR_WORD) | PACK_OPT_IN_INSTR_WORD;
+ } @new_pack_opts;
+ push @pack_opts, @new_pack_opts;
+ }
+
+ my $ret = ['', ':', @args];
+ my $score = 0;
+
+ foreach my $options (@pack_opts) {
+ my $this_opt_arg_pos = ($options & PACK_OPT_IN_INSTR_WORD) ? $opt_arg_pos : -1;
+ my($this_score,$this_result) =
+ do_pack_one($name, $options, $this_opt_arg_pos, $offset, @args);
+ if ($this_score > $score) {
+ $ret = $this_result;
+ $score = $this_score;
+ }
+ }
+ return @$ret;
+}
+
+sub do_pack_one {
+ my($name,$options,$opt_arg_pos,$offset,@args) = @_;
my($packable_args) = 0;
- my @is_packable; # Packability (boolean) for each argument.
- my $wide_packing = 0;
- my(@orig_args) = @args;
+ 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.
+ #
+ my %bits_needed = ('x' => 10,
+ 'y' => 10,
+ 'Q' => 10,
+ 'l' => 10,
+ 'S' => 16,
+ 'd' => 16,
+ 't' => 16);
+ if ($wordsize == 64) {
+ $bits_needed{'I'} = 32;
+ if ($options & PACK_JUMP) {
+ $bits_needed{'f'} = 32;
+ $bits_needed{'j'} = 32;
+ }
+ }
#
- # Count the number of packable arguments. If we encounter any 's' or 'd'
- # arguments, packing is not possible.
+ # Count the number of packable arguments.
#
- my $packable_types = "xytQ";
foreach my $arg (@args) {
- if ($arg =~ /^[$packable_types]/) {
+ if (defined $bits_needed{$arg}) {
$packable_args++;
- 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);
- } 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);
+ push @bits_needed, $bits_needed{$arg};
} else {
- push @is_packable, 0;
+ push @bits_needed, 0;
}
+ if ($arg =~ /^[fj]$/) {
+ # Only pack the first occurrence of 'f' or 'j'.
+ delete $bits_needed{'f'};
+ delete $bits_needed{'j'};
+ }
}
#
- # Get out of here if too few or too many 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 $options == 0) {
+ return (-1);
+ }
- my($size) = 0;
- my($pack_prefix) = '';
- my($down) = ''; # Pack commands (towards instruction
- # beginning).
- my($up) = ''; # Pack commands (storing back while
- # moving forward).
+ #
+ # Determine how many arguments we should pack into each word.
+ #
+ my @args_per_word;
+ my @need_wide_mask;
+ 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;
+ };
- my $args_per_word = $args_per_word[$packable_args];
- my @shift;
- my @mask;
- my @instr;
+ $next_word->();
+ $this_wordsize = 32 if $pack_in_iw;
+ for (my $arg_num = 0; $arg_num < @args; $arg_num++) {
+ my $needed = $bits_needed[$arg_num];
- 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]};
+ next unless $needed;
+ next if $arg_num == $opt_arg_pos;
+
+ if ($bits+$needed > $this_wordsize) { # Does not fit.
+ $next_word->();
+ }
+ if ($args_per_word[$word] == 4) { # Can't handle more than 4 args.
+ $next_word->();
+ }
+ if ($needed == 32 and $args_per_word[$word] > 1) {
+ # Must only pack two arguments in this word, and there
+ # are already at least two arguments here.
+ $next_word->();
+ }
+ $args_per_word[$word]++;
+ $bits += $needed;
+ if ($needed == 32) {
+ $need_wide_mask[$word]++;
+ }
+ if ($need_wide_mask[$word] and $bits > 32) {
+ # Can only pack two things in a word where one
+ # item is 32 bits. Force the next item into
+ # the next word.
+ $bits = $this_wordsize;
+ }
}
#
+ # Try to balance packing between words.
+ #
+ 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 {
+ $args_per_word[$#args_per_word-1]--;
+ $args_per_word[$#args_per_word]++;
+ }
+ } elsif (@args_per_word == 2 and
+ $args_per_word[0] == 4 and
+ $args_per_word[1] == 2) {
+ $args_per_word[0] = 3;
+ $args_per_word[1] = 3;
+ } elsif (@args_per_word == 2 and
+ $args_per_word[0] == 3 and
+ $args_per_word[1] == 1) {
+ $args_per_word[0] = 2;
+ $args_per_word[1] = 2;
+ }
+
+ my $size = 0;
+ my $pack_prefix = '';
+ my $down = ''; # Pack commands (towards instruction
+ # beginning).
+ my $up = ''; # Pack commands (storing back while
+ # moving forward).
+ my $arg_num = 0; # Number of argument.
+
+ # Skip an unpackable argument. Also handle packing of
+ # an single operand into the instruction word.
+ my $skip_unpackable = sub {
+ my($arg) = @_;
+
+ if ($arg_num == $opt_arg_pos) {
+ my $pack = chr(ord('#') + $arg_num);
+ $down = PACK_CMD_WIDE . "$pack$down";
+ my $unpack = "BeamExtraData(I[0])";
+ $args[$arg_num] = "packed:$arg:0:${arg}b($unpack)";
+ } elsif ($arg_size{$arg}) {
+ # Save the argument on the pack engine's stack.
+ my $push = 'g';
+ if ($type_bit{$arg} & $type_bit{'q'}) {
+ # The operand may be a literal.
+ $push = 'q';
+ } elsif ($type_bit{$arg} & $type_bit{'f'}) {
+ # The operand may be a failure label.
+ $push = 'f';
+ }
+ $down = "$push${down}";
+ $up = "${up}p";
+ }
+ };
+
+ #
# Now generate the packing instructions. One complication is that
# 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.
+ 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 $pack_word_size = ($pack_in_iw && $word == 0) ? 32 : $wordsize;
+
+ my($shref,$mref,$iref,$unpack_suffix) =
+ get_pack_parameters($name, $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) {
+ 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]);
+ my $macro = "$reg$unpack_suffix";
+ $args[$arg_num] = "packed:$reg:$this_size:$macro($unpack)";
+
+ $ap++;
+ } else {
+ $skip_unpackable->($reg);
+ }
+ $size += $this_size;
+ $arg_num++;
+ }
+ }
+
#
- # XXX Packing 3 't's in one word won't work. Sorry.
-
- my $did_some_packing = 0; # Nothing packed yet.
- my($ap) = 0; # Argument number within word.
- my($tmpnum) = 1; # Number of temporary variable.
- my($expr) = '';
- for (my $i = 0; $i < @args; $i++) {
- my($reg) = $args[$i];
- my($this_size) = $arg_size{$reg};
- if ($is_packable[$i]) {
- $this_size = 0;
- $did_some_packing = 1;
-
- if ($ap == 0) {
- $pack_prefix .= "tmp_packed$tmpnum = Arg($size);\n";
- $up .= "p";
- $down = "P$down";
- $this_size = 1;
- }
+ # Skip any unpackable arguments at the end.
+ #
+ while ($arg_num < @args) {
+ my $arg = $args[$arg_num];
+ $skip_unpackable->($arg);
+ $size += $arg_size{$arg};
+ $arg_num++;
+ }
- $down = "$instr[$ap]$down";
- my($unpack) = make_unpack($tmpnum, $shift[$ap], $mask[$ap]);
- $args[$i] = "pack:$this_size:$reg" . "b($unpack)";
+ my $pack_spec = "$down:$up";
+ my $score = pack_score($options, @args);
- if (++$ap == $args_per_word) {
- $ap = 0;
- $tmpnum++;
- }
- } elsif ($arg_size{$reg} && $did_some_packing) {
- #
- # This is an argument that can't be packed. Normally, we must
- # save it on the pack engine's stack, unless:
- #
- # 1. The argument has zero size (e.g. r(0)). Such arguments
- # will not be loaded. They disappear.
- # 2. If the argument is on the left of the first packed argument,
- # the packing engine will never access it (because the engine
- # operates from right-to-left).
- #
+ return ($score, [$pack_prefix,$pack_spec,@args]);
+}
- $down = "g${down}";
- $up = "${up}p";
- }
- $size += $this_size;
+sub get_pack_parameters {
+ my($name,$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;
}
- my $pack_spec = $down . $up;
- return ($pack_prefix, $pack_spec, @args);
+ unless (@shift) {
+ error("$name: internal packing 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 + 10*($max_spec_operands - $size);
+ if (($options & PACK_OPT_IN_INSTR_WORD) != 0) {
+ $score += 4;
+ } elsif ($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 {
- my($tmpnum, $shift, $mask) = @_;
+ my($packed_var, $shift, $mask) = @_;
- my($e) = "tmp_packed$tmpnum";
+ my $e = $packed_var;
$e = "($e>>$shift)" if $shift;
$e .= "&$mask" unless $mask eq $WHOLE_WORD;
$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';
@@ -1286,8 +2180,11 @@ sub parse_transformation {
#
my @to;
- if ($to =~ /^(\w+)\((.*?)\)/) {
- my($name, $arglist) = ($1, $2);
+ if ($to =~ /^(\w+)\((.*?)\)(.*)/) {
+ my($name, $arglist, $garbage) = ($1, $2, $3);
+ if ($garbage =~ /\S/) {
+ error("garbage after call to '$name()'");
+ }
@to = (compile_transform_function($name, split(/\s*,\s*/, $arglist)));
} else {
@to = split(/\s*\|\s*/, $to);
@@ -1357,12 +2254,19 @@ sub tr_parse_op {
if (/^([a-z*]+)(.*)/) {
$type = $1;
$_ = $2;
+ error("$type: only a single type is allowed on right side of transformations")
+ if not $src and length($type) > 1;
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")
- }
+ next if $src and $type eq '*';
+ error("$op: not a type")
+ unless defined $type_bit{$_};
+ error("$op: the type '$_' is not allowed in transformations")
+ unless defined $pattern_type{$_};
+ if (not $src) {
+ error("$op: type '$_' is not allowed on the right side of transformations")
+ unless defined $construction_type{$_};
+ }
+ }
}
# Get an optional condition. (In source.)
@@ -1395,10 +2299,18 @@ sub tr_parse_op {
}
# Get an optional value. (In destination.)
- $type_val = $type eq 'x' ? 1023 : 0;
+ if ($type eq 'x') {
+ $type_val = 1023;
+ } elsif ($type eq 'a') {
+ $type_val = 'am_Empty';
+ } else {
+ $type_val = 0;
+ }
if (/^=(.*)/) {
- error("value not allowed in source: $op")
+ error("$op: value not allowed in source")
if $src;
+ error("$op: the type 'n' must not be given a value")
+ if $type eq 'n';
$type_val = $1;
$_ = '';
}
@@ -1408,13 +2320,16 @@ sub tr_parse_op {
error("garbage '$_' after operand: $op")
unless /^\s*$/;
- # Test that destination has no conditions.
+ # Check the conditions.
- unless ($src) {
- error("condition not allowed in destination: $op")
+ if ($src) {
+ error("$op: the type '$type' is not allowed to be compared with a literal value")
+ if $cond and not $construction_type{$type};
+ } else {
+ error("$op: condition not allowed in destination")
if $cond;
- error("variable name and type cannot be combined in destination: $op")
- if $var && $type;
+ error("$op: variable name and type cannot be combined in destination")
+ if $var and $type;
}
($var,$type,$type_val,$cond,$cond_val);
diff --git a/erts/emulator/utils/make_tables b/erts/emulator/utils/make_tables
index 47e1528958..094a35ae4b 100755
--- a/erts/emulator/utils/make_tables
+++ b/erts/emulator/utils/make_tables
@@ -59,7 +59,6 @@ my %dirty_bif_tab;
my @bif;
my @bif_info;
-my $dirty_schedulers = 'no';
my $dirty_schedulers_test = 'no';
my $hipe = 'no';
@@ -73,10 +72,6 @@ while (@ARGV && $ARGV[0] =~ /^-(\w+)/) {
$include = shift;
die "No directory for -include argument specified"
unless defined $include;
- } elsif($opt eq '-ds') {
- $dirty_schedulers = shift;
- die "No -ds argument specified"
- unless defined $dirty_schedulers;
} elsif($opt eq '-dst') {
$dirty_schedulers_test = shift;
die "No -dst argument specified"
@@ -140,21 +135,19 @@ while (<>) {
push(@bif_info, [$type, $sched_type, $alias3, $alias]);
} elsif ($type eq 'dirty-cpu' or $type eq 'dirty-io'
or $type eq 'dirty-cpu-test' or $type eq 'dirty-io-test') {
- if ($dirty_schedulers eq 'yes') {
- my($bif,$other) = (@args);
- $bif =~ m@^([a-z_.'0-9]+):(.*)/(\d)$@ or error("invalid BIF");
- my($mod,$name,$arity) = ($1,$2,$3);
- my $mfa = "$mod:$name/$arity";
- if (($type eq 'dirty-cpu')
- or (($dirty_schedulers_test eq 'yes')
- and ($type eq 'dirty-cpu-test'))) {
- $dirty_bif_tab{$mfa} = 'dirty_cpu';
- } elsif (($type eq 'dirty-io')
- or (($dirty_schedulers_test eq 'yes')
- and ($type eq 'dirty-io-test'))) {
- $dirty_bif_tab{$mfa} = 'dirty_io';
- }
- }
+ my($bif,$other) = (@args);
+ $bif =~ m@^([a-z_.'0-9]+):(.*)/(\d)$@ or error("invalid BIF");
+ my($mod,$name,$arity) = ($1,$2,$3);
+ my $mfa = "$mod:$name/$arity";
+ if (($type eq 'dirty-cpu')
+ or (($dirty_schedulers_test eq 'yes')
+ and ($type eq 'dirty-cpu-test'))) {
+ $dirty_bif_tab{$mfa} = 'dirty_cpu';
+ } elsif (($type eq 'dirty-io')
+ or (($dirty_schedulers_test eq 'yes')
+ and ($type eq 'dirty-io-test'))) {
+ $dirty_bif_tab{$mfa} = 'dirty_io';
+ }
} else {
error("invalid line");
}