diff options
Diffstat (limited to 'erts/emulator/utils/beam_makeops')
-rwxr-xr-x | erts/emulator/utils/beam_makeops | 2015 |
1 files changed, 1485 insertions, 530 deletions
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops index 0b7c16f606..d7791d23fa 100755 --- a/erts/emulator/utils/beam_makeops +++ b/erts/emulator/utils/beam_makeops @@ -2,56 +2,56 @@ # # %CopyrightBegin% # -# Copyright Ericsson AB 1998-2012. All Rights Reserved. +# Copyright Ericsson AB 1998-2017. All Rights Reserved. # -# The contents of this file are subject to the Erlang Public License, -# Version 1.1, (the "License"); you may not use this file except in -# compliance with the License. You should have received a copy of the -# Erlang Public License along with this software. If not, it can be -# retrieved online at http://www.erlang.org/. +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at # -# Software distributed under the License is distributed on an "AS IS" -# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See -# the License for the specific language governing rights and limitations -# under the License. +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. # # %CopyrightEnd% # use strict; use vars qw($BEAM_FORMAT_NUMBER); +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; 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]; + +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. @@ -77,6 +77,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; @@ -85,17 +89,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. # @@ -107,7 +116,6 @@ my @if_line; # my $te_max_vars = 0; # Max number of variables ever needed. my %gen_transform; -my %min_window; my %match_engine_ops; # All opcodes for the match engine. my %gen_transform_offset; my @transformations; @@ -133,13 +141,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 @@ -175,21 +185,22 @@ sub define_type_bit { } # Composed types. - define_type_bit('d', $type_bit{'x'} | $type_bit{'y'} | $type_bit{'r'}); + define_type_bit('d', $type_bit{'x'} | $type_bit{'y'}); define_type_bit('c', $type_bit{'i'} | $type_bit{'a'} | $type_bit{'n'} | $type_bit{'q'}); define_type_bit('s', $type_bit{'d'} | $type_bit{'i'} | - $type_bit{'a'} | $type_bit{'n'}); + $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'}); @@ -216,6 +227,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"); + } } # @@ -229,17 +246,69 @@ 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 pack options. +# + +if ($wordsize == 64) { + @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. +# + +$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/\\$//) { $_ .= <>; @@ -247,6 +316,7 @@ while (<>) { } next if /^\s*$/; next if /^\#/; + next if m@^//@; # # Handle %if. @@ -295,39 +365,50 @@ 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; + $hotness = COLD; next; } - + # - # Handle macro definitions. + # Handle transformations. # - 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); + if (/=>/) { + parse_transformation($_); next; } # - # Handle transformations. + # Handle C code blocks. # - if (/=>/) { - &parse_transformation($_); - next; + 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; } # @@ -336,8 +417,8 @@ while (<>) { $op_num = undef; if (s/^(\d+):\s*//) { $op_num = $1; - $op_num != 0 or &error("Opcode 0 invalid"); - &error("Opcode $op_num already defined") + $op_num != 0 or error("Opcode 0 invalid"); + error("Opcode $op_num already defined") if defined $gen_opname[$op_num]; } @@ -348,11 +429,11 @@ while (<>) { my($obsolete) = $1; my($name) = $2; my($arity) = $3; - $name =~ /^[a-z]/ or &error("Opname must start with a lowercase letter"); + $name =~ /^[a-z]/ or error("Opname must start with a lowercase letter"); defined $gen_arity{$name} and $gen_arity{$name} != $arity and - &error("Opname $name already defined with arity $gen_arity{$name}"); + error("Opname $name already defined with arity $gen_arity{$name}"); defined $unnumbered{$name,$arity} and - &error("Opname $name already defined with arity $gen_arity{$name}"); + error("Opname $name already defined with arity $gen_arity{$name}"); if (defined $op_num) { # Numbered generic operation $gen_opname[$op_num] = $name; @@ -361,7 +442,6 @@ while (<>) { $gen_arity{$name} = $arity; $gen_to_spec{"$name/$arity"} = undef; $num_specific{"$name/$arity"} = 0; - $min_window{"$name/$arity"} = 255; $obsolete[$op_num] = defined $obsolete; } else { # Unnumbered generic operation. push(@unnumbered_generic, [$name, $arity]); @@ -374,17 +454,9 @@ 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"); - } - push(@{$specific_op{"$name/$arity"}}, [$name, $hot, @args]); + my($name,$arity) = parse_specific_op($_); if (defined $op_num) { - &error("specific instructions must not be numbered"); + error("specific instructions must not be numbered"); } elsif (!defined($gen_arity{$name}) && !defined($unnumbered{$name,$arity})) { # # Create an unumbered generic instruction too. @@ -419,7 +491,6 @@ $num_file_opcodes = @gen_opname; $gen_arity{$name} = $arity; $gen_to_spec{"$name/$arity"} = undef; $num_specific{"$name/$arity"} = 0; - $min_window{"$name/$arity"} = 255; } } @@ -427,7 +498,19 @@ $num_file_opcodes = @gen_opname; # Produce output for the chosen target. # -&$target; +&$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. @@ -439,11 +522,41 @@ 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"; open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n"; - &comment('C'); + comment('C'); print "#ifdef HAVE_CONFIG_H\n"; print "# include \"config.h\"\n"; print "#endif\n\n"; @@ -456,7 +569,7 @@ sub emulator_output { print '#include "beam_load.h"', "\n"; print "\n"; - print "char tag_to_letter[] = {\n "; + print "const char tag_to_letter[] = {\n "; for ($i = 0; $i < length($genop_types); $i++) { print "'$tag_type[$i]', "; } @@ -469,8 +582,8 @@ sub emulator_output { # # Generate code for specific ops. # - my($spec_opnum) = 0; - print "OpEntry opc[] = {\n"; + my $spec_opnum = 0; + print "const OpEntry opc[] = {\n"; foreach $key (sort keys %specific_op) { $gen_to_spec{$key} = $spec_opnum; $num_specific{$key} = @{$specific_op{$key}}; @@ -484,40 +597,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 @@ -526,16 +625,19 @@ sub emulator_output { my(@bits) = (0) x ($max_spec_operands/2); my($i); + my $involves_r = 0; for ($i = 0; $i < $max_spec_operands && defined $args[$i]; $i++) { my $t = $args[$i]; - if (defined $type_bit{$t}) { - my $shift = $max_genop_types * ($i % 2); - $bits[int($i/2)] |= $type_bit{$t} << $shift; + my $bits = $type_bit{$t}; + if ($t eq 'r') { + $bits |= $type_bit{'x'}; + $involves_r |= 1 << $i; } + my $shift = $max_genop_types * ($i % 2); + $bits[int($i/2)] |= $bits << $shift; } printf "/* %3d */ ", $spec_opnum; - my $print_name = $sign ne '' ? "${name}_$sign" : $name; my $init = "{"; my $sep = ""; foreach (@bits) { @@ -543,25 +645,38 @@ sub emulator_output { $sep = ","; } $init .= "}"; - &init_item($print_name, $init, $size, $pack, $sign, 0); - $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++; } } print "};\n\n"; - print "int num_instructions = $spec_opnum;\n\n"; + print "const int num_instructions = $spec_opnum;\n\n"; + + # + # Print the array for instruction counts. + # + + print "#ifdef ERTS_OPCODE_COUNTER_SUPPORT\n"; + print "Uint erts_instr_count[$spec_opnum];\n"; + print "#endif\n"; + print "\n"; # # Generate transformations. # - &tr_gen(@transformations); + tr_gen(@transformations); # # Print the generic instruction table. # - print "GenOpEntry gen_opc[] = {\n"; + print "const GenOpEntry gen_opc[] = {\n"; for ($i = 0; $i < @gen_opname; $i++) { if ($i == $num_file_opcodes) { print "\n/*\n * Internal generic instructions.\n */\n\n"; @@ -570,7 +685,7 @@ sub emulator_output { my($arity) = $gen_arity[$i]; printf "/* %3d */ ", $i; if (!defined $name) { - &init_item("", 0, 0, 0, -1); + init_item("", 0, 0, 0, -1); } else { my($key) = "$name/$arity"; my($tr) = defined $gen_transform_offset{$key} ? @@ -582,7 +697,7 @@ sub emulator_output { $is_transformed{$name,$arity} or error("instruction $key has no specific instruction"); $spec_op = -1 unless defined $spec_op; - &init_item($name, $arity, $spec_op, $num_specific, $tr, $min_window{$key}); + init_item($name, $arity, $spec_op, $num_specific, $tr); } } print "};\n"; @@ -592,7 +707,7 @@ sub emulator_output { # $name = "$outdir/beam_opcodes.h"; open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n"; - &comment('C'); + comment('C'); print "#ifndef __OPCODES_H__\n"; print "#define __OPCODES_H__\n\n"; @@ -600,24 +715,34 @@ sub emulator_output { print "#define MAX_GENERIC_OPCODE ", $num_file_opcodes-1, "\n"; print "#define NUM_GENERIC_OPS ", scalar(@gen_opname), "\n"; print "#define NUM_SPECIFIC_OPS ", scalar(@op_to_name), "\n"; + print "#define SCRATCH_X_REG 1023\n"; print "\n"; - print "#ifdef ARCH_64\n"; - print "# define BEAM_WIDE_MASK 0xFFFFUL\n"; - print "# define BEAM_LOOSE_MASK 0x1FFFUL\n"; - print "#if HALFWORD_HEAP\n"; - print "# define BEAM_TIGHT_MASK 0x1FFCUL\n"; - print "#else\n"; - print "# define BEAM_TIGHT_MASK 0x1FF8UL\n"; - print "#endif\n"; - print "# define BEAM_WIDE_SHIFT 32\n"; - print "# define BEAM_LOOSE_SHIFT 16\n"; - print "# define BEAM_TIGHT_SHIFT 16\n"; - print "#else\n"; - print "# define BEAM_LOOSE_MASK 0xFFF\n"; - print "# define BEAM_TIGHT_MASK 0xFFC\n"; - print "# define BEAM_LOOSE_SHIFT 16\n"; - print "# define BEAM_TIGHT_SHIFT 10\n"; - print "#endif\n"; + if ($wordsize == 32) { + print "#if defined(ARCH_64)\n"; + print qq[ #error "32-bit architecture assumed, but ARCH_64 is defined"\n]; + print "#endif\n"; + print "#define BEAM_LOOSE_MASK 0xFFF\n"; + print "#define BEAM_TIGHT_MASK 0xFFC\n"; + print "#define BEAM_LOOSE_SHIFT 16\n"; + print "#define BEAM_TIGHT_SHIFT 10\n"; + } elsif ($wordsize == 64) { + print "#if !defined(ARCH_64)\n"; + print qq[ #error "64-bit architecture assumed, but ARCH_64 not defined"\n]; + print "#endif\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"; # @@ -627,14 +752,14 @@ sub emulator_output { my $letter; my $tag_num = 0; - &comment('C', "The following operand types for generic instructions", + comment('C', "The following operand types for generic instructions", "occur in beam files."); foreach $letter (split('', $compiler_types)) { print "#define TAG_$letter $tag_num\n"; $tag_num++; } print "\n"; - &comment('C', "The following operand types are only used in the loader."); + comment('C', "The following operand types are only used in the loader."); foreach $letter (split('', $loader_types)) { print "#define TAG_$letter $tag_num\n"; $tag_num++; @@ -652,8 +777,8 @@ sub emulator_output { print "#define TE_MAX_VARS $te_max_vars\n"; print "\n"; - print "extern char tag_to_letter[];\n"; - print "extern Uint op_transform[];\n"; + print "extern const char tag_to_letter[];\n"; + print "extern const Uint op_transform[];\n"; print "\n"; for ($i = 0; $i < @op_to_name; $i++) { @@ -682,7 +807,7 @@ sub emulator_output { print "#define DEFINE_COUNTING_LABELS"; for ($i = 0; $i < @op_to_name; $i++) { my($name) = $op_to_name[$i]; - print " \\\nCountCase($name): opc[$i].count++; goto lb_$name;"; + print " \\\nCountCase($name): erts_instr_count[$i]++; goto lb_$name;"; } print "\n\n"; @@ -701,27 +826,38 @@ sub emulator_output { $name = "$outdir/beam_tr_funcs.h"; open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n"; - &comment('C'); - &tr_gen_call(@call_table); + comment('C'); + tr_gen_call(@call_table); $name = "$outdir/beam_pred_funcs.h"; open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n"; - &comment('C'); - &tr_gen_call(@pred_table); + comment('C'); + tr_gen_call(@pred_table); # # Implementation of operations for emulator. # $name = "$outdir/beam_hot.h"; open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n"; - &comment('C'); - &print_code(\%hot_code); + comment('C'); + 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); + comment('C'); + print_code(COLD); +} +sub print_name { + my($name,@args) = @_; + my $sign = join '', @args; + $sign =~ s/[?]//g; + $sign ne '' ? "${name}_$sign" : $name; } sub init_item { @@ -733,7 +869,7 @@ sub init_item { print "${sep}NULL"; } elsif (/^\{/) { print "$sep$_"; - } elsif (/^-?\d/) { + } elsif (/^-?\d+$/) { print "$sep$_"; } else { print "$sep\"$_\""; @@ -749,29 +885,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). # @@ -783,7 +937,7 @@ sub compiler_output { open(STDOUT, ">$outdir/$name") || die "Failed to open $name for writing: $!\n"; print "-module($module).\n"; - &comment('erlang'); + comment('erlang'); print "-export([format_number/0]).\n"; print "-export([opcode/2,opname/1]).\n"; @@ -795,7 +949,7 @@ sub compiler_output { for ($i = 0; $i < @gen_opname; $i++) { next unless defined $gen_opname[$i]; print "%%" if $obsolete[$i]; - print "opcode(", "e($gen_opname[$i]), ", $gen_arity[$i]) -> $i;\n"; + print "opcode(", quote($gen_opname[$i]), ", $gen_arity[$i]) -> $i;\n"; } print "opcode(Name, Arity) -> erlang:error(badarg, [Name,Arity]).\n\n"; @@ -803,7 +957,7 @@ sub compiler_output { for ($i = 0; $i < @gen_opname; $i++) { next unless defined $gen_opname[$i]; print "opname($i) -> {", - "e($gen_opname[$i]), ",$gen_arity[$i]};\n"; + quote($gen_opname[$i]), ",$gen_arity[$i]};\n"; } print "opname(Number) -> erlang:error(badarg, [Number]).\n"; @@ -812,7 +966,7 @@ sub compiler_output { # my($hrl_name) = "$outdir/${module}.hrl"; open(STDOUT, ">$hrl_name") || die "Failed to open $hrl_name for writing: $!\n"; - &comment('erlang'); + comment('erlang'); for ($i = 0; $i < @tag_type && $i < 8; $i++) { print "-define(tag_$tag_type[$i], $i).\n"; @@ -822,18 +976,66 @@ 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; - &error("Bad opcode name '$name'") + # Check for various errors. + error("Bad opcode name '$name'") unless $name =~ /^[a-z][\w\d_]*$/; - for ($i = 0; $i < @args; $i++) { - &error("Argument " . ($i+1) . ": invalid type '$args[$i]'") - unless defined $arg_size{$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}; + } + } + 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 @old_res = @res; + @res = (); + my $marker = ($arg =~ s/[?]$//) ? '?' : ''; + foreach my $type (split(//, $arg)) { + foreach my $args_ref (@old_res) { + my @args = @$args_ref; + push @args, "$type$marker"; + push @res, \@args; + } + } + } + + # Store each specific instruction. + my $key = "$name/$arity"; + foreach my $args_ref (@res) { + @args = @$args_ref; + 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 { @@ -877,58 +1079,311 @@ 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]; + } + + # 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 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($gen_dest_arg) = 'StoreSimpleDest'; - my($i); +sub combine_instruction_group { + my($group,@in_instrs) = @_; + my $gcode = ''; # Code for the entire group. + my $group_hotness = COLD; - # 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, - ); + # 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"; + } - # Pick up the macro to use and its flags (if any). + # Variables. + my %offsets; + my @instrs; + my %num_references; # Number of references from other sub instructions. + my $group_size = 999; - $macro = $macro{$name} if defined $macro{$name}; - $flags = $macro_flags{$name} if defined $macro_flags{$name}; + # + # 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}++; + } + } + + # 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; + } # - # 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"); + } + + ($group_hotness,"{\n$gcode\n}\n\n",@opcase_labels); +} + +sub micro_label { + my $label = shift; + $label =~ s/[.]/__/g; + $label; +} - while ($flags =~ /-arg_(\w)/g) { - $incl_arg{$1} = 1; - }; + +# +# 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); + $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, + @_); + 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 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 (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); } # @@ -936,254 +1391,657 @@ sub basic_generator { # the macro. # + my $need_block = 0; + my $arg_offset = $offset; + @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; "; - push(@f, "dst"); - push(@f_types, $_); - $prefix .= "dst = Arg($size);\n"; - $gen_dest_arg = 'StoreResult'; - 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; } # - # If requested, pass a pointer to the destination register. - # The destination must be the last operand. + # If the implementation is in beam_emu.c, there is nothing + # more to do. # - if ($flags =~ /-gen_dest/) { - push(@f, $gen_dest_arg); + unless (defined $c_code_ref) { + return ($size+1, undef, ''); } + my $group_size = ($params{comp_size} || $size) + $inc; + # - # Add a fail action macro 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 =~ /-fail_action/ and do { - 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 }; - } - } - }; + if (@f != @c_args) { + error("$where: defining '$name' with ", scalar(@c_args), + " arguments instead of expected ", scalar(@f), " arguments"); + } + + 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"; # - # Add a size argument if requested. + # 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);"; + } - $flags =~ /-size/ and do { - push(@f, $size); - }; + # + # 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); +} - # 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;", - "}"); - } else { - $code = join("\n", - "{ $var_decls", - "BeamInstr* next;", - "PreFetch($size, next);", - "$macro_code", - "NextPF($size, next);", - "}", ""); - } +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"; } - # Return the size and code for the macro (if any). - $size++; - ($size, $code, $pack_spec); + $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 'ARG_POSITION') { + if ($body =~ /^I\[(\d+)\]$/) { + $body = $1; + } else { + $body = 0; + } + } elsif ($name eq 'IS_PACKED') { + $body = ($body =~ /^I\[\d+\]$/) ? 0 : 1; + } + + # 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($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 @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); + 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; - &error("too many packable arguments") if $packable_args > 4; - - my($size) = 0; - my($pack_prefix) = ''; - my($down) = ''; # Pack commands (towards instruction - # beginning). - my($up) = ''; # Pack commands (storing back while - # moving forward). - my $args_per_word; - if ($packable_args < 4 or $wordsize == 64) { - $args_per_word = $packable_args; - } else { - # 4 packable argument, 32 bit wordsize. Need 2 words. - $args_per_word = 2; + if ($packable_args == 0) { + return (-1); + } elsif ($packable_args == 1 and $options == 0) { + return (-1); } - my @shift; - my @mask; - my @instr; + # + # 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; + }; - 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_word->(); + $this_wordsize = 32 if $pack_in_iw; + for (my $arg_num = 0; $arg_num < @args; $arg_num++) { + my $needed = $bits_needed[$arg_num]; + + 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; + } + + 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; - my $pack_spec = $down . $up; - return ($pack_prefix, $pack_spec, @args); + # 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'; @@ -1210,7 +2068,7 @@ sub parse_transformation { foreach (@from) { if (/^(\w+)\((.*?)\)/) { my($name, $arglist) = ($1, $2); - $_ = (&compile_transform_function($name, split(/\s*,\s*/, $arglist))); + $_ = (compile_transform_function($name, split(/\s*,\s*/, $arglist))); } else { (@op) = split; ($rest_var,$_) = compile_transform(1, $rest_var, @op); @@ -1224,9 +2082,12 @@ sub parse_transformation { # my @to; - if ($to =~ /^(\w+)\((.*?)\)/) { - my($name, $arglist) = ($1, $2); - @to = (&compile_transform_function($name, split(/\s*,\s*/, $arglist))); + 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); foreach (@to) { @@ -1248,7 +2109,7 @@ sub compile_transform { my $arity = 0; foreach (@ops) { - my(@list) = &tr_parse_op($src, $_); + my(@list) = tr_parse_op($src, $_); if ($list[1] eq '*') { $rest_var = $list[0]; } elsif (defined $rest_var and $list[0] eq $rest_var) { @@ -1285,7 +2146,7 @@ sub tr_parse_op { if (/^([A-Z]\w*)(.*)/) { $var = $1; $_ = $2; - &error("garbage after variable") + error("garbage after variable") unless /^=(.*)/ or /^(\s*)$/; $_ = $1; } @@ -1296,8 +2157,10 @@ sub tr_parse_op { $type = $1; $_ = $2; foreach (split('', $type)) { - &error("bad type in $op") + error("bad type in $op") unless defined $type_bit{$_} or $type eq '*'; + $_ eq 'r' and + error("$op: 'r' is not allowed in transformations") } } @@ -1331,14 +2194,17 @@ sub tr_parse_op { } # Get an optional value. (In destination.) + $type_val = $type eq 'x' ? 1023 : 0; if (/^=(.*)/) { + error("value not allowed in source: $op") + if $src; $type_val = $1; $_ = ''; } # Nothing more is allowed after the command. - &error("garbage '$_' after operand: $op") + error("garbage '$_' after operand: $op") unless /^\s*$/; # Test that destination has no conditions. @@ -1350,11 +2216,6 @@ sub tr_parse_op { if $var && $type; } - # Test that source has no values. - if ($src) { - error("value not allowed in source: $op") - if $type_val; - } ($var,$type,$type_val,$cond,$cond_val); } @@ -1369,8 +2230,7 @@ sub tr_gen { foreach $ref (@g) { my($line, $orig_transform, $from_ref, $to_ref) = @$ref; - my $used_ref = used_vars($from_ref, $to_ref); - my $so_far = tr_gen_from($line, $used_ref, @$from_ref); + my $so_far = tr_gen_from($line, @$from_ref); tr_gen_to($line, $orig_transform, $so_far, @$to_ref); } @@ -1378,7 +2238,7 @@ sub tr_gen { # Print the generated transformation engine. # my($offset) = 0; - print "Uint op_transform[] = {\n"; + print "const Uint op_transform[] = {\n"; foreach $key (sort keys %gen_transform) { $gen_transform_offset{$key} = $offset; my @instr = @{$gen_transform{$key}}; @@ -1421,58 +2281,14 @@ sub tr_gen { print "};\n\n"; } -sub used_vars { - my($from_ref,$to_ref) = @_; - my %used; - my %seen; - - foreach my $ref (@$from_ref) { - my($name,$arity,@ops) = @$ref; - if ($name =~ /^[.]/) { - foreach my $var (@ops) { - $used{$var} = 1; - } - } else { - # Any variable that is used at least twice on the - # left-hand side is used. (E.g. "move R R".) - foreach my $op (@ops) { - my($var, $type, $type_val) = @$op; - next if $var eq ''; - $used{$var} = 1 if $seen{$var}; - $seen{$var} = 1; - } - } - } - - foreach my $ref (@$to_ref) { - my($name, $arity, @ops) = @$ref; - if ($name =~ /^[.]/) { - foreach my $var (@ops) { - $used{$var} = 1; - } - } else { - foreach my $op (@ops) { - my($var, $type, $type_val) = @$op; - next if $var eq ''; - $used{$var} = 1; - } - } - } - \%used; -} - sub tr_gen_from { - my($line,$used_ref,@tr) = @_; + my($line,@tr) = @_; my(%var) = (); my(%var_type); my($var_num) = 0; my(@code); - my($min_window) = 0; - my(@fix_rest_args); - my(@fix_pred_funcs); my($op, $ref); # Loop variables. my $where = "left side of transformation in line $line: "; - my %var_used = %$used_ref; my $may_fail = 0; my $is_first = 1; @@ -1494,8 +2310,20 @@ sub tr_gen_from { my $var; my(@args); - push(@fix_pred_funcs, scalar(@code)); - push(@code, [$name, @ops]); + foreach $var (@ops) { + error($where, "variable '$var' unbound") + unless defined $var{$var}; + if ($var_type{$var} eq 'scalar') { + push(@args, "var[$var{$var}]"); + } else { + push(@args, "rest_args"); + } + } + my $pi = tr_next_index(\@pred_table, \%pred_table, $name, @args); + my $op = make_op("$name()", 'pred', $pi); + my @slots = grep(/^\d+/, map { $var{$_} } @ops); + op_slot_usage($op, @slots); + push(@code, $op); next; } @@ -1503,12 +2331,11 @@ sub tr_gen_from { # Check that $name/$arity refers to a valid generic instruction. # - &error($where, "invalid generic op $name/$arity") + error($where, "invalid generic op $name/$arity") unless defined $gen_opnum{$name,$arity}; $opnum = $gen_opnum{$name,$arity}; push(@code, make_op("$name/$arity", 'next_instr', $opnum)); - $min_window++; foreach $op (@ops) { my($var, $type, $type_val, $cond, $val) = @$op; my $ignored_var = "$var (ignored)"; @@ -1532,11 +2359,11 @@ sub tr_gen_from { $type_mask |= $type_bit{$_}; } if ($cond ne 'is_eq') { - push(@code, &make_op($types, 'is_type', $type_mask)); + push(@code, make_op($types, 'is_type', $type_mask)); } else { $cond = ''; - push(@code, &make_op("$types== $val", 'is_type_eq', - $type_mask, $val)); + push(@code, make_op("$types== $val", 'is_type_eq', + $type_mask, $val)); } } } @@ -1545,32 +2372,38 @@ sub tr_gen_from { my($m, $f, $a) = split(/:/, $val); $ignored_var = ''; $may_fail = 1; - push(@code, &make_op('', "$cond", "am_$m", + push(@code, make_op('', "$cond", "am_$m", "am_$f", $a)); } elsif ($cond ne '') { $ignored_var = ''; $may_fail = 1; - push(@code, &make_op('', "$cond", $val)); + push(@code, make_op('', "$cond", $val)); } if ($var ne '') { if (defined $var{$var}) { $ignored_var = ''; $may_fail = 1; - push(@code, &make_op($var, 'is_same_var', $var{$var})); + my $op = make_op($var, 'is_same_var', $var{$var}); + op_slot_usage($op, $var{$var}); + push(@code, $op); } elsif ($type eq '*') { - # - # Reserve a hole for a 'rest_args' instruction. - # + foreach my $type (values %var_type) { + error("only one use of a '*' variable is " . + "allowed on the left hand side of " . + "a transformation") + if $type eq 'array'; + } $ignored_var = ''; - push(@fix_rest_args, scalar(@code)); - push(@code, $var); - } elsif ($var_used{$var}) { + $var{$var} = 'unnumbered'; + $var_type{$var} = 'array'; + push(@code, make_op($var, 'rest_args')); + } else { $ignored_var = ''; $var_type{$var} = 'scalar'; $var{$var} = $var_num; $var_num++; - push(@code, &make_op($var, 'set_var', $var{$var})); + push(@code, make_op($var, 'set_var', $var{$var})); } } if (is_instr($code[$#code], 'set_var')) { @@ -1579,7 +2412,7 @@ sub tr_gen_from { my $var = $ref->[1][1]; push(@code, make_op($comment, 'set_var_next_arg', $var)); } else { - push(@code, &make_op($ignored_var, 'next_arg')); + push(@code, make_op($ignored_var, 'next_arg')); } } @@ -1593,46 +2426,14 @@ sub tr_gen_from { # push(@code, make_op($may_fail ? '' : 'always reached', 'commit')); - # - # If there is an rest_args instruction, we must insert its correct - # variable number (higher than any other). - # - my $index; - &error("only one use of a '*' variable is allowed on the left hand side of a transformation") - if @fix_rest_args > 1; - foreach $index (@fix_rest_args) { - my $var = $code[$index]; - $var{$var} = $var_num++; - $var_type{$var} = 'array'; - splice(@code, $index, 1, &make_op($var, 'rest_args', $var{$var})); - } - - foreach $index (@fix_pred_funcs) { - my($name, @ops) = @{$code[$index]}; - my(@args); - my $var; - - foreach $var (@ops) { - &error($where, "variable '$var' unbound") - unless defined $var{$var}; - if ($var_type{$var} eq 'scalar') { - push(@args, "var[$var{$var}]"); - } else { - push(@args, "var+$var{$var}"); - } - } - my $pi = tr_next_index(\@pred_table, \%pred_table, $name, @args); - splice(@code, $index, 1, make_op("$name()", 'pred', $pi)); - } - $te_max_vars = $var_num if $te_max_vars < $var_num; - [$min_window, \%var, \%var_type, \@code]; + [\%var, \%var_type, \@code]; } sub tr_gen_to { my($line, $orig_transform, $so_far, @tr) = @_; - my($min_window, $var_ref, $var_type_ref, $code_ref) = @$so_far; + my($var_ref, $var_type_ref, $code_ref) = @$so_far; my(%var) = %$var_ref; my(%var_type) = %$var_type_ref; my(@code) = @$code_ref; @@ -1656,18 +2457,21 @@ sub tr_gen_to { my(@args); foreach $var (@ops) { - &error($where, "variable '$var' unbound") + error($where, "variable '$var' unbound") unless defined $var{$var}; if ($var_type{$var} eq 'scalar') { push(@args, "var[$var{$var}]"); } else { - push(@args, "var+$var{$var}"); + push(@args, "rest_args"); } } pop(@code); # Get rid of 'commit' instruction my $index = tr_next_index(\@call_table, \%call_table, $name, @args); - push(@code, make_op("$name()", 'call_end', $index)); + my $op = make_op("$name()", 'call_end', $index); + my @slots = grep(/^\d+/, map { $var{$_} } @ops); + op_slot_usage($op, @slots); + push(@code, $op); last; } @@ -1676,7 +2480,7 @@ sub tr_gen_to { # my($key) = "$name/$arity"; - &error($where, "invalid generic op $name/$arity") + error($where, "invalid generic op $name/$arity") unless defined $gen_opnum{$name,$arity}; my $opnum = $gen_opnum{$name,$arity}; @@ -1689,15 +2493,17 @@ sub tr_gen_to { my($var, $type, $type_val) = @$op; if ($type eq '*') { - push(@code, make_op($var, 'store_rest_args', $var{$var})); + push(@code, make_op($var, 'store_rest_args')); } elsif ($var ne '') { - &error($where, "variable '$var' unbound") + error($where, "variable '$var' unbound") unless defined $var{$var}; - push(@code, &make_op($var, 'store_var_next_arg', $var{$var})); + my $op = make_op($var, 'store_var_next_arg', $var{$var}); + op_slot_usage($op, $var{$var}); + push(@code, $op); } elsif ($type ne '') { - push(@code, &make_op('', 'store_type', "TAG_$type")); + push(@code, make_op('', 'store_type', "TAG_$type")); if ($type_val) { - push(@code, &make_op('', 'store_val', $type_val)); + push(@code, make_op('', 'store_val', $type_val)); } push(@code, make_op('', 'next_arg')); } @@ -1708,6 +2514,10 @@ sub tr_gen_to { push(@code, make_op('', 'end')) unless is_instr($code[$#code], 'call_end'); + tr_maybe_keep(\@code); + tr_maybe_rename(\@code); + tr_remove_unused(\@code); + # # Chain together all codes segments having the same first operation. # @@ -1716,8 +2526,6 @@ sub tr_gen_to { my($dummy, $arity); ($dummy, $op, $arity) = @$first; my($comment) = "\n/*\n * Line $line:\n * $orig_transform\n */\n\n"; - $min_window{$key} = $min_window - if $min_window{$key} > $min_window; my $prev_last; $prev_last = pop(@{$gen_transform{$key}}) @@ -1735,6 +2543,148 @@ sub tr_gen_to { push(@{$gen_transform{$key}}, @code), } +sub tr_maybe_keep { + my($ref) = @_; + my @last_instr; + my $pos; + my $reused_instr; + + for (my $i = 0; $i < @$ref; $i++) { + my $instr = $$ref[$i]; + my($size, $instr_ref, $comment) = @$instr; + my($op, @args) = @$instr_ref; + if ($op eq 'next_instr') { + @last_instr = ($args[0]); + } elsif ($op eq 'set_var_next_arg') { + push @last_instr, $args[0]; + } elsif ($op eq 'next_arg') { + push @last_instr, 'ignored'; + } elsif ($op eq 'new_instr') { + unless (defined $pos) { + # 'new_instr' immediately after 'commit'. + $reused_instr = $args[0]; + return unless shift(@last_instr) == $reused_instr; + $pos = $i - 1; + } else { + # Second 'new_instr' after 'commit'. The instructions + # from $pos up to and including $i - 1 rebuilds the + # existing instruction exactly. + my $name = $gen_opname[$reused_instr]; + my $arity = $gen_arity[$reused_instr]; + my $reuse = make_op("$name/$arity", 'keep'); + splice @$ref, $pos, $i-$pos, ($reuse); + return; + } + } elsif ($op eq 'store_var_next_arg') { + return unless shift(@last_instr) eq $args[0]; + } elsif (defined $pos) { + return; + } + } +} + +sub tr_maybe_rename { + my($ref) = @_; + my $s = 'left'; + my $a = 0; + my $num_args = 0; + my $new_instr; + my $first; + my $i; + + for ($i = 1; $i < @$ref; $i++) { + my $instr = $$ref[$i]; + my($size, $instr_ref, $comment) = @$instr; + my($op, @args) = @$instr_ref; + + if ($s eq 'left') { + if ($op eq 'set_var_next_arg') { + if ($num_args == $a and $args[0] == $a) { + $num_args++; + } + $a++; + } elsif ($op eq 'next_arg') { + $a++; + } elsif ($op eq 'commit') { + $a = 0; + $first = $i; + $s = 'committed'; + } elsif ($op eq 'next_instr') { + return; + } + } elsif ($s eq 'committed') { + if ($op eq 'new_instr') { + $new_instr = $args[0]; + $a = 0; + $s = 'right'; + } else { + return; + } + } elsif ($s eq 'right') { + if ($op eq 'store_var_next_arg' && $args[0] == $a) { + $a++; + } elsif ($op eq 'end' && $a <= $num_args) { + my $name = $gen_opname[$new_instr]; + my $arity = $gen_arity[$new_instr]; + my $new_op = make_op("$name/$arity", 'rename', $new_instr); + splice @$ref, $first, $i-$first+1, ($new_op); + return; + } else { + return; + } + } + } +} + +sub tr_remove_unused { + my($ref) = @_; + my %used; + + # Collect all used variables. + for my $instr (@$ref) { + my $uref = $$instr[3]; + for my $slot (@$uref) { + $used{$slot} = 1; + } + } + + # Replace 'set_var_next_arg' with 'next_arg' if the variable + # is never used. + for my $instr (@$ref) { + my($size, $instr_ref, $comment) = @$instr; + my($op, @args) = @$instr_ref; + if ($op eq 'set_var_next_arg') { + my $var = $args[0]; + next if $used{$var}; + $instr = make_op("$comment (ignored)", 'next_arg'); + } + } + + # Delete a sequence of 'next_arg' instructions when they are + # redundant before instructions such as 'commit'. + my @opcode; + my %ending = (call_end => 1, + commit => 1, + next_instr => 1, + pred => 1, + rename => 1, + keep => 1); + for (my $i = 0; $i < @$ref; $i++) { + my $instr = $$ref[$i]; + my($size, $instr_ref, $comment) = @$instr; + my($opcode) = @$instr_ref; + + if ($ending{$opcode}) { + my $first = $i; + $first-- while $first > 0 and $opcode[$first-1] eq 'next_arg'; + my $n = $i - $first; + splice @$ref, $first, $n; + $i -= $n; + } + $opcode[$i] = $opcode; + } +} + sub tr_code_len { my($sum) = 0; my($ref); @@ -1747,7 +2697,12 @@ sub tr_code_len { sub make_op { my($comment, @op) = @_; - [scalar(@op), [@op], $comment]; + [scalar(@op), [@op], $comment, []]; +} + +sub op_slot_usage { + my($op_ref, @slots) = @_; + $$op_ref[3] = \@slots; } sub is_instr { |