aboutsummaryrefslogtreecommitdiffstats
path: root/erts/emulator/utils
diff options
context:
space:
mode:
Diffstat (limited to 'erts/emulator/utils')
-rwxr-xr-xerts/emulator/utils/beam_makeops1239
-rwxr-xr-xerts/emulator/utils/make_tables33
2 files changed, 926 insertions, 346 deletions
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops
index 0a30553f71..a9b2c8861c 100755
--- a/erts/emulator/utils/beam_makeops
+++ b/erts/emulator/utils/beam_makeops
@@ -20,13 +20,16 @@
#
use strict;
use vars qw($BEAM_FORMAT_NUMBER);
+use constant COLD => 0;
+use constant WARM => 1;
+use constant HOT => 2;
$BEAM_FORMAT_NUMBER = 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).
@@ -54,11 +57,6 @@ $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
@@ -83,6 +81,10 @@ my %num_specific;
my %gen_to_spec;
my %specific_op;
+# 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 +93,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.
+
+# Definitions for instructions combined from micro instructions.
+my %combined_instrs;
-my %hot_code;
-my %cold_code;
+my @generated_code; # Generated code.
+my %sort_order;
my @unnumbered_generic;
my %unnumbered;
my %is_transformed;
+
#
# Pre-processor.
#
@@ -138,13 +145,15 @@ 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
@@ -186,16 +195,16 @@ 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'});
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 +231,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");
+ }
}
#
@@ -240,27 +255,56 @@ while (@ARGV && $ARGV[0] =~ /^-(.*)/) {
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;
+}
+
#
# 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;
+}
+
+#
+# Add placeholders for built-in macros.
+#
+
+$c_code{'IS_PACKED'} = ['$Expr',"built-in macro",('Expr')];
+$c_code{'ARG_POSITION'} = ['$Expr',"built-in macro",('Expr')];
+foreach my $name (keys %c_code) {
+ $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 +312,7 @@ while (<>) {
}
next if /^\s*$/;
next if /^\#/;
+ next if m@^//@;
#
# Handle %if.
@@ -316,30 +361,16 @@ while (<>) {
}
#
- # 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 +383,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;
@@ -402,7 +458,7 @@ while (<>) {
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);
+ save_specific_ops($name, $arity, $hotness, @args);
if (defined $op_num) {
error("specific instructions must not be numbered");
} elsif (!defined($gen_arity{$name}) && !defined($unnumbered{$name,$arity})) {
@@ -449,6 +505,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 +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";
@@ -488,7 +587,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;
@@ -506,37 +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, $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 +641,6 @@ sub emulator_output {
}
printf "/* %3d */ ", $spec_opnum;
- my $print_name = $sign ne '' ? "${name}_$sign" : $name;
my $init = "{";
my $sep = "";
foreach (@bits) {
@@ -566,8 +648,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,9 +732,9 @@ 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";
+ print "#define BEAM_WIDE_MASK 0xFFFFFFFFull\n";
+ print "#define BEAM_LOOSE_MASK 0xFFFFull\n";
+ print "#define BEAM_TIGHT_MASK 0xFFFFull\n";
print "#define BEAM_WIDE_SHIFT 32\n";
print "#define BEAM_LOOSE_SHIFT 16\n";
print "#define BEAM_TIGHT_SHIFT 16\n";
@@ -750,13 +836,23 @@ 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 ne '' ? "${name}_$sign" : $name;
}
sub init_item {
@@ -784,29 +880,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).
#
@@ -893,6 +1007,18 @@ sub save_specific_ops {
}
}
+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 {
my(@message) = @_;
my($where) = $. ? "$ARGV($.): " : "";
@@ -934,58 +1060,272 @@ 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];
+ }
+}
+
+sub combine_instruction_group {
+ my($group,@in_instrs) = @_;
+ my $gcode = ''; # Code for the entire group.
+ my $group_hotness = COLD;
+
+ # 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";
+ }
+
+ # Variables.
+ my %offsets;
+ my @instrs;
+ my %num_references;
+ my $group_size = 0;
+
+ # 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($s, 1, @first);
+ $offsets{$s} = $offset
+ unless defined $offsets{$s} and $offsets{$s} >= $offset;
+ $offset += $size - 1;
+ my $label = micro_label($s);
+ $num_references{$label} = 0;
+ 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];
+ }
+ }
- # 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,
- );
+ # 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;
+ $num_references{$next}++ if $next;
+ my $instr_info = "$opcase:$label:$next:$s:$size:@args";
+ push @all_instrs, [$label,$offsets{$s},$instr_info];
+ }
+ }
- # Pick up the macro to use and its flags (if any).
+ my %order_to_instrs;
+ my %label_to_offset;
+ my %order_to_offset;
+ foreach my $instr (@all_instrs) {
+ my($label,$offset,$instr_info) = @$instr;
+ my $sort_key = sprintf("%02d.%02d", $offset, $num_references{$label});
+ 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{$label}) {
+ $gcode .= "$label:\n";
+ }
+
+ my $flags = '';
+ my $transfer_to_next = '';
+ my $dec = 0;
+
+ unless ($i == $#slots) {
+ $flags = "-no_next";
+ my $next_offset = $label_to_offset{$next};
+ $dec = $next_offset - ($offset + $size);
+ $transfer_to_next = "I -= $dec;\n" if $dec;
+ $transfer_to_next .= "goto $next;\n\n";
+ }
+
+ my($gen_code,$down,$up) =
+ cg_combined_code($s, 1, $flags, $offset,
+ $group_size-$offset-$dec, @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;
+ }
- $macro = $macro{$name} if defined $macro{$name};
- $flags = $macro_flags{$name} if defined $macro_flags{$name};
+ foreach my $print_name (@opcase_labels) {
+ my $info = $spec_op_info{$print_name};
+ $info->{'adj'} = $info->{'size'} - $group_size - 1;
+ }
#
- # Add any arguments to be included as macro arguments (for instance,
- # 'p' is usually not an argument, except for calls).
+ # 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");
+ }
- while ($flags =~ /-arg_(\w)/g) {
- $incl_arg{$1} = 1;
- };
+ ($group_hotness,"{\n$gcode\n}\n\n",@opcase_labels);
+}
+
+sub micro_label {
+ my $label = shift;
+ $label =~ s/[.]/__/g;
+ $label;
+}
+
+
+#
+# Basic code generation for one instruction.
+#
+
+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;
+ my $prefix = '';
+ my $tmp_arg_num = 1;
+ my $pack_spec = '';
+ my $var_decls = '';
#
- # Pack arguments if requested.
+ # Pack arguments for hot code with an implementation.
#
- if ($flags =~ /-pack/ && $hot) {
- ($prefix, $pack_spec, @args) = do_pack(@args);
+ my $c_code_ref = $c_code{$name};
+ if ($pack and defined $c_code_ref and $name ne 'catch') {
+ ($var_decls, $pack_spec, @args) = do_pack($offset, @args);
}
#
@@ -993,259 +1333,503 @@ sub basic_generator {
# the macro.
#
+ my $need_block = 0;
+ my $arg_offset = $offset;
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;
+ 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");
+ 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, there is nothing
+ # more to do.
#
+ unless (defined $c_code_ref) {
+ 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 };
- }
- }
- };
+ $group_size = $size unless defined $group_size;
#
- # 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);
+ $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* _nextpf = " .
+ "(BeamInstr *) I[$instr_offset];\n";
+ $dispatch_next = "\nI += $instr_offset;\n" .
+ "ASSERT(VALID_INSTR(_nextpf));\n" .
+ "Goto(_nextpf);";
+ }
+
+ #
+ # 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",
+ "}", "");
+ ($size+1, $code, $pack_spec);
+}
+
+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)) {
+ $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 'ARG_POSITION') {
+ if ($body =~ /^I\[(\d+)\]$/) {
+ $body = $1;
+ } else {
+ $body = 0;
+ }
+ } elsif ($name eq 'IS_PACKED') {
+ $body = ($body =~ /^I\[\d+\]$/) ? 0 : 1;
}
- # Return the size and code for the macro (if any).
- $size++;
- ($size, $code, $pack_spec);
+ # Wrap body if needed and return resul.t
+ $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($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.
#
- # Count the number of packable arguments. If we encounter any 's' or 'd'
- # arguments, packing is not possible.
+ # 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;
+ }
+
+ #
+ # 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;
}
}
#
- # Get out of here if too few or too many arguments.
+ # Try to pack 'f' and 'j', but not at expense at worse packing
+ # for other operands. For example, given the arguments "f x x", we
+ # want the 'x' operands to be packed, not 'f' and 'x' packed and
+ # the final 'x' not packed.
#
- return ('', '', @args) if $packable_args < 2;
- my($size) = 0;
- my($pack_prefix) = '';
- my($down) = ''; # Pack commands (towards instruction
- # beginning).
- my($up) = ''; # Pack commands (storing back while
- # moving forward).
+ if ($wordsize == 64 and $packable_args == 1) {
+ for (my $i = 0; $i < @args; $i++) {
+ if ($args[$i] =~ /^[fj]$/) {
+ $bits_needed[$i] = 32;
+ $packable_args++;
+ last;
+ }
+ }
+ }
- my $args_per_word = $args_per_word[$packable_args];
- my @shift;
- my @mask;
- my @instr;
+ #
+ # Nothing to pack unless there are at least 2 packable arguments.
+ #
+ return ('', ':', @args) if $packable_args < 2;
- 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]};
+ #
+ # Determine how many arguments we should pack into each word.
+ #
+ my @args_per_word;
+ my @need_wide_mask;
+ my $bits = 0;
+ my $word = 0;
+ $args_per_word[0] = 0;
+ $need_wide_mask[0] = 0;
+ for (my $i = 0; $i < @args; $i++) {
+ if ($bits_needed[$i]) {
+ my $needed = $bits_needed[$i];
+
+ my $next_word = sub {
+ $word++;
+ $args_per_word[$word] = 0;
+ $need_wide_mask[$word] = 0;
+ $bits = 0;
+ };
+
+ if ($bits+$needed > $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 = $wordsize;
+ }
+ }
}
#
+ # Try to balance packing between words.
+ #
+ if ($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).
+
+ # Skip an unpackable argument.
+ my $skip_unpackable = sub {
+ my($arg) = @_;
+
+ if ($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.
- #
- # 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;
- }
-
- $down = "$instr[$ap]$down";
- my($unpack) = make_unpack($tmpnum, $shift[$ap], $mask[$ap]);
- $args[$i] = "pack:$this_size:$reg" . "b($unpack)";
+ my $arg_num = 0;
+ 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 @shift;
+ my @mask;
+ my @instr;
+
+ if ($need_wide_mask[$word]) {
+ @shift = ('0', 'BEAM_WIDE_SHIFT');
+ @mask = ('BEAM_WIDE_MASK', $WHOLE_WORD);
+ @instr = ('w', 'w');
+ } else {
+ @shift = @{$pack_shift[$args_per_word]};
+ @mask = @{$pack_mask[$args_per_word]};
+ @instr = @{$pack_instr[$args_per_word]};
+ }
- 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).
- #
+ 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) {
+ $pack_prefix .= "Eterm $packed_var = " .
+ arg_offset($size+$offset) . ";\n";
+ $up .= "p";
+ $down = "P$down";
+ $this_size = 1;
+ }
+
+ $down = "$instr[$ap]$down";
+ my $unpack = make_unpack($packed_var, $shift[$ap], $mask[$ap]);
+ $args[$arg_num] = "packed:$reg:$this_size:$reg" . "b($unpack)";
+
+ $ap++;
+ } else {
+ $skip_unpackable->($reg);
+ }
+ $size += $this_size;
+ $arg_num++;
+ }
+ }
- $down = "g${down}";
- $up = "${up}p";
- }
- $size += $this_size;
+ #
+ # Skip any unpackable arguments at the end.
+ #
+ while ($arg_num < @args) {
+ $skip_unpackable->($args[$arg_num]);
+ $arg_num++;
}
- my $pack_spec = $down . $up;
+ my $pack_spec = "$down:$up";
return ($pack_prefix, $pack_spec, @args);
}
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 +1870,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);
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");
}