/erts/emulator/utils/beam_makeops
Perl | 1727 lines | 1278 code | 216 blank | 233 comment | 155 complexity | 30dd9d3f0499c248050b33f6b81b2ab9 MD5 | raw file
Possible License(s): BSD-2-Clause
- #!/usr/bin/env perl
- #
- # %CopyrightBegin%
- #
- # Copyright Ericsson AB 1998-2011. 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/.
- #
- # 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.
- #
- # %CopyrightEnd%
- #
- use strict;
- use vars qw($BEAM_FORMAT_NUMBER);
- $BEAM_FORMAT_NUMBER = undef;
- my $target = \&emulator_output;
- my $outdir = "."; # Directory for output files.
- my $verbose = 0;
- my $hot = 1;
- my $num_file_opcodes = 0;
- my $wordsize = 32;
- # 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];
- # 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
- # whole family of related specific instructions. Specific instructions
- # are those executed by the VM interpreter during run-time.
- # Maximum number of operands for a generic instruction.
- # In beam_load.c the MAX_OPARGS refers to the maximum
- # number of operands for generic instructions.
- my $max_gen_operands = 8;
- # Maximum number of operands for a specific instruction.
- # Must be even. The beam_load.c file must be updated, too.
- my $max_spec_operands = 6;
- # The maximum number of primitive genop_types.
- my $max_genop_types = 16;
- my %gen_opnum;
- my %num_specific;
- my %gen_to_spec;
- my %specific_op;
- my %gen_arity;
- my @gen_arity;
- my @gen_opname;
- my @op_to_name;
- my @obsolete;
- my %macro;
- my %macro_flags;
- my %hot_code;
- my %cold_code;
- my @unnumbered_generic;
- my %unnumbered;
- my %is_transformed;
- #
- # Code transformations.
- #
- 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;
- my @call_table;
- my %call_table;
- my @pred_table;
- my %pred_table;
- # Operand types for generic instructions.
- my $compiler_types = "uiaxyfhz";
- my $loader_types = "nprvlqo";
- my $genop_types = $compiler_types . $loader_types;
- #
- # Defines the argument types and their loaded size assuming no packing.
- #
- my %arg_size = ('r' => 0, # x(0) - x register zero
- 'x' => 1, # x(N), N > 0 - x register
- 'y' => 1, # y(N) - y register
- 'i' => 1, # tagged integer
- 'a' => 1, # tagged atom
- 'n' => 0, # NIL (implicit)
- 'c' => 1, # tagged constant (integer, atom, nil)
- 's' => 1, # tagged source; any of the above
- '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
- 'b' => 1, # pointer to bif
- 'A' => 1, # arity value
- 'P' => 1, # byte offset into tuple or stack
- 'Q' => 1, # like 'P', but packable
- 'h' => 1, # character
- 'l' => 1, # float reg
- 'q' => 1, # literal term
- );
- #
- # Generate bits.
- #
- my %type_bit;
- my @tag_type;
- sub define_type_bit {
- my($tag,$val) = @_;
- defined $type_bit{$tag} and
- sanity("the tag '$tag' has already been defined with the value ",
- $type_bit{$tag});
- $type_bit{$tag} = $val;
- }
- {
- my($bit) = 1;
- my(%bit);
- foreach (split('', $genop_types)) {
- push(@tag_type, $_);
- define_type_bit($_, $bit);
- $bit{$_} = $bit;
- $bit *= 2;
- }
- # Composed types.
- define_type_bit('d', $type_bit{'x'} | $type_bit{'y'} | $type_bit{'r'});
- 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'});
- 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('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'});
- }
- #
- # Pre-define the 'fail' instruction. It is used internally
- # by the 'try_me_else_fail' instruction.
- #
- $match_engine_ops{'TOP_fail'} = 1;
- #
- # Sanity checks.
- #
- {
- if (@tag_type > $max_genop_types) {
- sanity("\$max_genop_types is $max_genop_types, ",
- "but there are ", scalar(@tag_type),
- " primitive tags defined\n");
- }
- foreach my $tag (@tag_type) {
- sanity("tag '$tag': primitive tags must be named with lowercase letters")
- unless $tag =~ /^[a-z]$/;
- }
- }
- #
- # Parse command line options.
- #
- while (@ARGV && $ARGV[0] =~ /^-(.*)/) {
- $_ = $1;
- shift;
- ($target = \&emulator_output), next if /^emulator/;
- ($target = \&compiler_output), next if /^compiler/;
- ($outdir = shift), next if /^outdir/;
- ($wordsize = shift), next if /^wordsize/;
- ($verbose = 1), next if /^v/;
- die "$0: Bad option: -$_\n";
- }
- #
- # Parse the input files.
- #
- while (<>) {
- my($op_num);
- chomp;
- if (s/\\$//) {
- $_ .= <>;
- redo unless eof(ARGV);
- }
- next if /^\s*$/;
- next if /^\#/;
-
- #
- # Handle assignments.
- #
- if (/^([\w_][\w\d_]+)=(.*)/) {
- no strict 'refs';
- my($name) = $1;
- $$name = $2;
- next;
- }
- #
- # Handle %hot/%cold.
- #
- if (/^\%hot/) {
- $hot = 1;
- 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);
- next;
- }
- #
- # Handle transformations.
- #
- if (/=>/) {
- &parse_transformation($_);
- next;
- }
- #
- # Parse off the number of the operation.
- #
- $op_num = undef;
- if (s/^(\d+):\s*//) {
- $op_num = $1;
- $op_num != 0 or &error("Opcode 0 invalid");
- &error("Opcode $op_num already defined")
- if defined $gen_opname[$op_num];
- }
- #
- # Parse: Name/Arity (generic instruction)
- #
- if (m@^(-)?(\w+)/(\d)\s*$@) {
- my($obsolete) = $1;
- my($name) = $2;
- my($arity) = $3;
- $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}");
- defined $unnumbered{$name,$arity} and
- &error("Opname $name already defined with arity $gen_arity{$name}");
-
- if (defined $op_num) { # Numbered generic operation
- $gen_opname[$op_num] = $name;
- $gen_arity[$op_num] = $arity;
- $gen_opnum{$name,$arity} = $op_num;
- $gen_arity{$name} = $arity;
- $gen_to_spec{"$name/$arity"} = undef;
- $num_specific{"$name/$arity"} = 0;
- $min_window{"$name/$arity"} = 255;
- $obsolete[$op_num] = $obsolete eq '-';
- } else { # Unnumbered generic operation.
- push(@unnumbered_generic, [$name, $arity]);
- $unnumbered{$name,$arity} = 1;
- }
- next;
- }
- #
- # 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 ($obsolete[$gen_opnum{$name,$arity}]) {
- error("specific instructions may not be specified for obsolete instructions");
- }
- push(@{$specific_op{"$name/$arity"}}, [$name, $hot, @args]);
- if (defined $op_num) {
- &error("specific instructions must not be numbered");
- } elsif (!defined($gen_arity{$name}) && !defined($unnumbered{$name,$arity})) {
- #
- # Create an unumbered generic instruction too.
- #
- push(@unnumbered_generic, [$name, $arity]);
- $unnumbered{$name,$arity} = 1;
- }
- } continue {
- close(ARGV) if eof(ARGV);
- }
- $num_file_opcodes = @gen_opname;
- #
- # Number all generic operations without numbers.
- #
- {
- my $ref;
- foreach $ref (@unnumbered_generic) {
- my($name, $arity) = @$ref;
- my $op_num = @gen_opname;
- push(@gen_opname, $name);
- push(@gen_arity, $arity);
- $gen_opnum{$name,$arity} = $op_num;
- $gen_arity{$name} = $arity;
- $gen_to_spec{"$name/$arity"} = undef;
- $num_specific{"$name/$arity"} = 0;
- $min_window{"$name/$arity"} = 255;
- }
- }
- #
- # Produce output for the chosen target.
- #
- &$target;
- #
- # Produce output needed by the emulator/loader.
- #
- sub emulator_output {
- my $i;
- my $name;
- my $key; # Loop variable.
- #
- # Information about opcodes (beam_opcodes.c).
- #
- $name = "$outdir/beam_opcodes.c";
- open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
- &comment('C');
- print "#ifdef HAVE_CONFIG_H\n";
- print "# include \"config.h\"\n";
- print "#endif\n\n";
- print '#include "sys.h"', "\n";
- print '#include "erl_vm.h"', "\n";
- print '#include "export.h"', "\n";
- print '#include "erl_process.h"', "\n";
- print '#include "bif.h"', "\n";
- print '#include "erl_atom_table.h"', "\n";
- print '#include "beam_load.h"', "\n";
- print "\n";
- print "char tag_to_letter[] = {\n ";
- for ($i = 0; $i < length($genop_types); $i++) {
- print "'$tag_type[$i]', ";
- }
- for (; $i < @tag_type; $i++) {
- print "'_', ";
- }
- print "\n};\n";
- print "\n";
- #
- # Generate code for specific ops.
- #
- my($spec_opnum) = 0;
- print "OpEntry opc[] = {\n";
- foreach $key (sort keys %specific_op) {
- $gen_to_spec{$key} = $spec_opnum;
- $num_specific{$key} = @{$specific_op{$key}};
- #
- # Pick up all instructions and manufacture sort keys; we must have
- # the most specific instructions appearing first (e.g. an 'x' operand
- # should be matched before 's' or 'd').
- #
- my(%items) = ();
- foreach (@{$specific_op{$key}}) {
- my($name, $hot, @args) = @{$_};
- my($sign) = join('', @args);
- # The primitive types should sort before other types.
- my($sort_key) = $sign;
- eval "\$sort_key =~ tr/$genop_types/./";
- $sort_key .= ":$sign";
- $items{$sort_key} = [$name, $hot, $sign, @args];
- }
- #
- # Now call the generator for the sorted result.
- #
- foreach (sort keys %items) {
- my($name, $hot, $sign, @args) = @{$items{$_}};
- 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
- # instruction.
- #
- my(@bits) = (0) x ($max_spec_operands/2);
- my($i);
- 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;
- }
- }
- printf "/* %3d */ ", $spec_opnum;
- my $print_name = $sign ne '' ? "${name}_$sign" : $name;
- my $init = "{";
- my $sep = "";
- foreach (@bits) {
- $init .= sprintf("%s0x%X", $sep, $_);
- $sep = ",";
- }
- $init .= "}";
- &init_item($print_name, $init, $size, $pack, $sign, 0);
- $op_to_name[$spec_opnum] = $instr;
- $spec_opnum++;
- }
- }
- print "};\n\n";
- print "int num_instructions = $spec_opnum;\n\n";
- #
- # Generate transformations.
- #
- &tr_gen(@transformations);
- #
- # Print the generic instruction table.
- #
- print "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";
- }
- my($name) = $gen_opname[$i];
- my($arity) = $gen_arity[$i];
- printf "/* %3d */ ", $i;
- if (!defined $name) {
- &init_item("", 0, 0, 0, -1);
- } else {
- my($key) = "$name/$arity";
- my($tr) = defined $gen_transform_offset{$key} ?
- $gen_transform_offset{$key} : -1;
- my($spec_op) = $gen_to_spec{$key};
- my($num_specific) = $num_specific{$key};
- defined $spec_op or
- $obsolete[$gen_opnum{$name,$arity}] or
- $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});
- }
- }
- print "};\n";
- #
- # Information about opcodes (beam_opcodes.h).
- #
- $name = "$outdir/beam_opcodes.h";
- open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
- &comment('C');
- print "#ifndef __OPCODES_H__\n";
- print "#define __OPCODES_H__\n\n";
- print "#define BEAM_FORMAT_NUMBER $BEAM_FORMAT_NUMBER\n";
- 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 "\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";
- print "\n";
- #
- # Definitions of tags.
- #
- my $letter;
- my $tag_num = 0;
- &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.");
- foreach $letter (split('', $loader_types)) {
- print "#define TAG_$letter $tag_num\n";
- $tag_num++;
- }
- print "\n#define BEAM_NUM_TAGS $tag_num\n\n";
- $i = 0;
- foreach (sort keys %match_engine_ops) {
- print "#define $_ $i\n";
- $i++;
- }
- print "#define NUM_TOPS $i\n";
- print "\n";
- 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 "\n";
- for ($i = 0; $i < @op_to_name; $i++) {
- print "#define op_$op_to_name[$i] $i\n";
- }
- print "\n";
- print "#define NUMBER_OF_OPCODES ",scalar(@op_to_name),"\n";
- for ($i = 0; $i < @op_to_name; $i++) {
- print "#define op_count_$op_to_name[$i] ",$i+scalar(@op_to_name),"\n";
- }
- print "\n";
- print "#define DEFINE_OPCODES";
- foreach (@op_to_name) {
- print " \\\n&&lb_$_,";
- }
- print "\n\n";
- print "#define DEFINE_COUNTING_OPCODES";
- foreach (@op_to_name) {
- print " \\\n&&lb_count_$_,";
- }
- print "\n\n";
- 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 "\n\n";
- for ($i = 0; $i < @gen_opname; $i++) {
- print "#define genop_$gen_opname[$i]_$gen_arity[$i] $i\n"
- if defined $gen_opname[$i];
- }
- print "#endif\n";
- #
- # Extension of transform engine.
- #
- $name = "$outdir/beam_tr_funcs.h";
- open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
- &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);
- #
- # 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);
- $name = "$outdir/beam_cold.h";
- open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
- &comment('C');
- &print_code(\%cold_code);
- }
- sub init_item {
- my($sep) = "";
- print "{";
- foreach (@_) {
- if (!defined $_) {
- print "${sep}NULL";
- } elsif (/^\{/) {
- print "$sep$_";
- } elsif (/^-?\d/) {
- print "$sep$_";
- } else {
- print "$sep\"$_\"";
- }
- $sep = ", ";
- }
- print "},\n";
- }
- sub q {
- my($str) = @_;
- "\"$str\"";
- }
- 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;
- }
- foreach (sort keys %sorted) {
- print $sorted{$_};
- }
- }
- #
- # Produce output needed by the compiler back-end (assembler).
- #
- sub compiler_output {
- my($module) = 'beam_opcodes';
- my($name) = "${module}.erl";
- my($i);
- open(STDOUT, ">$outdir/$name") || die "Failed to open $name for writing: $!\n";
- print "-module($module).\n";
- &comment('erlang');
- print "-export([format_number/0]).\n";
- print "-export([opcode/2,opname/1]).\n";
- print "\n";
- print "-spec format_number() -> $BEAM_FORMAT_NUMBER.\n";
- print "format_number() -> $BEAM_FORMAT_NUMBER.\n\n";
- print "-spec opcode(atom(), 0..", $max_gen_operands, ") -> 1..", $num_file_opcodes-1, ".\n";
- 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(Name, Arity) -> erlang:error(badarg, [Name,Arity]).\n\n";
- print "-spec opname(1..", $num_file_opcodes-1, ") -> {atom(),0..", $max_gen_operands, "}.\n";
- for ($i = 0; $i < @gen_opname; $i++) {
- next unless defined $gen_opname[$i];
- print "opname($i) -> {",
- "e($gen_opname[$i]), ",$gen_arity[$i]};\n";
- }
- print "opname(Number) -> erlang:error(badarg, [Number]).\n";
- #
- # Generate .hrl file.
- #
- my($name) = "$outdir/${module}.hrl";
- open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
- &comment('erlang');
- for ($i = 0; $i < @tag_type && $i < 8; $i++) {
- print "-define(tag_$tag_type[$i], $i).\n";
- }
- print "\n";
- }
- #
- # Check an operation for validity.
- #
- sub syntax_check {
- my($name, @args) = @_;
- my($i);
- &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]};
- }
- }
- sub error {
- my(@message) = @_;
- my($where) = $. ? "$ARGV($.): " : "";
- die $where, @message, "\n";
- }
- sub sanity {
- die "internal error: ", @_, "\n";
- }
- sub comment {
- my($lang, @comments) = @_;
- my($prefix);
- if ($lang eq 'C') {
- print "/*\n";
- $prefix = " * ";
- } elsif ($lang eq 'erlang') {
- $prefix = '%% ';
- } else {
- $prefix = '# ';
- }
- my(@prog) = split('/', $0);
- my($prog) = $prog[$#prog];
- if (@comments) {
- my $line;
- foreach $line (@comments) {
- print "$prefix$line\n";
- }
- } else {
- print "$prefix Warning: Do not edit this file.\n";
- print "$prefix Auto-generated by '$prog'.\n";
- }
- if ($lang eq 'C') {
- print " */\n";
- }
- print "\n";
- }
- #
- # Basic implementation of instruction in emulator loop
- # (assuming no packing).
- #
- 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);
- # 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,
- );
- # Pick up the macro to use and its flags (if any).
- $macro = $macro{$name} if defined $macro{$name};
- $flags = $macro_flags{$name} if defined $macro_flags{$name};
- #
- # Add any arguments to be included as macro arguments (for instance,
- # 'p' is usually not an argument, except for calls).
- #
- while ($flags =~ /-arg_(\w)/g) {
- $incl_arg{$1} = 1;
- };
- #
- # Pack arguments if requested.
- #
- if ($flags =~ /-pack/ && $hot) {
- ($prefix, $pack_spec, @args) = &do_pack(@args);
- }
- #
- # Calculate the size of the instruction and generate each argument for
- # the macro.
- #
- 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; };
- die "$name: The generator can't handle $_, at";
- }
- $size += $this_size;
- }
- #
- # If requested, pass a pointer to the destination register.
- # The destination must be the last operand.
- #
- if ($flags =~ /-gen_dest/) {
- push(@f, $gen_dest_arg);
- }
- #
- # Add a fail action macro if requested.
- #
- $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 };
- }
- }
- };
- #
- # Add a size argument if requested.
- #
- $flags =~ /-size/ and do {
- push(@f, $size);
- };
- # 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);",
- "}", "");
- }
- }
- # Return the size and code for the macro (if any).
- $size++;
- ($size, $code, $pack_spec);
- }
- sub do_pack {
- my(@args) = @_;
- my($packable_args) = 0;
- my @is_packable; # Packability (boolean) for each argument.
- my $wide_packing = 0;
- #
- # Count the number of packable arguments. If we encounter any 's' or 'd'
- # arguments, packing is not possible.
- #
- my $packable_types = "xytQ";
- foreach my $arg (@args) {
- if ($arg =~ /^[$packable_types]/) {
- $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);
- } else {
- push @is_packable, 0;
- }
- }
- #
- # Get out of here if too few or too many arguments.
- #
- 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;
- }
- my @shift;
- my @mask;
- my @instr;
- 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]};
- }
- #
- # 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)";
- 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).
- #
- $down = "g${down}";
- $up = "${up}p";
- }
- $size += $this_size;
- }
- my $pack_spec = $down . $up;
- return ($pack_prefix, $pack_spec, @args);
- }
- sub make_unpack {
- my($tmpnum, $shift, $mask) = @_;
- my($e) = "tmp_packed$tmpnum";
- $e = "($e>>$shift)" if $shift;
- $e .= "&$mask" unless $mask eq $WHOLE_WORD;
- $e;
- }
- sub quote {
- local($_) = @_;
- return "'$_'" if $_ eq 'try';
- return "'$_'" if $_ eq 'catch';
- return "'$_'" if $_ eq 'receive';
- return "'$_'" if $_ =~ /^[A-Z]/;
- $_;
- }
- #
- # Parse instruction transformations when they first appear.
- #
- sub parse_transformation {
- local($_) = @_;
- my($orig) = $_;
- my($from, $to) = split(/\s*=>\s*/);
- my(@op);
- # The source instructions.
- my(@from) = split(/\s*\|\s*/, $from);
- foreach (@from) {
- if (/^(\w+)\((.*?)\)/) {
- my($name, $arglist) = ($1, $2);
- $_ = (&compile_transform_function($name, split(/\s*,\s*/, $arglist)));
- } else {
- (@op) = split;
- $_ = &compile_transform(1, @op);
- }
- }
- #
- # Check for a function which should be called to provide the new
- # instructions if the left-hand side matched. Otherwise there is
- # an explicit list of instructions.
- #
- my @to;
- if ($to =~ /^(\w+)\((.*?)\)/) {
- my($name, $arglist) = ($1, $2);
- @to = (&compile_transform_function($name, split(/\s*,\s*/, $arglist)));
- } else {
- @to = split(/\s*\|\s*/, $to);
- foreach (@to) {
- (@op) = split;
- $_ = &compile_transform(0, @op);
- }
- }
- push(@transformations, [$., $orig, [@from], [reverse @to]]);
- }
- sub compile_transform_function {
- my($name, @args) = @_;
- [".$name", 0, @args];
- }
- sub compile_transform {
- my($src, $name, @ops) = @_;
- my $arity = 0;
-
- foreach (@ops) {
- my(@list) = &tr_parse_op($src, $_);
- $arity++ unless $list[1] eq '*';
- $_ = [ @list ];
- }
- if ($obsolete[$gen_opnum{$name,$arity}]) {
- error("obsolete function must not be used in transformations");
- }
- if ($src) {
- $is_transformed{$name,$arity} = 1;
- }
-
- [$name,$arity,@ops];
- }
- sub tr_parse_op {
- my($src, $op) = @_;
- my($var) = '';
- my($type) = '';
- my($type_val) = 0;
- my($cond) = '';
- my($cond_val) = '';
- local($_) = $op;
- # Get the variable name if any.
- if (/^([A-Z]\w*)(.*)/) {
- $var = $1;
- $_ = $2;
- &error("garbage after variable")
- unless /^=(.*)/ or /^(\s*)$/;
- $_ = $1;
- }
- # Get the type if any.
- if (/^([a-z*]+)(.*)/) {
- $type = $1;
- $_ = $2;
- foreach (split('', $type)) {
- &error("bad type in $op")
- unless defined $type_bit{$_} or $type eq '*';
- }
- }
- # Get an optional condition. (In source.)
- if (/^==(.*)/) {
- $cond = 'is_eq';
- $cond_val = $1;
- $_ = '';
- } elsif (/^\$is_bif(.*)/) {
- $cond = 'is_bif';
- $cond_val = -1;
- $_ = $1;
- } elsif (/^\$is_not_bif(.*)/) {
- $cond = 'is_not_bif';
- $cond_val = -1;
- $_ = $1;
- } elsif (m@^\$bif:(\w+):(\w+)/(\d)(.*)@) {
- $cond = 'is_bif';
- if ($1 eq 'erlang') {
- $cond_val = "BIF_$2_$3";
- } else {
- $cond_val = "BIF_$1_$2_$3";
- }
- $_ = $4;
- } elsif (m@^\$func:(\w+):(\w+)/([_\d])(.*)@) {
- my $arity = $3 eq '_' ? 1024 : $3;
- $cond = 'is_func';
- $cond_val = "$1:$2:$arity";
- $_ = $4;
- }
- # Get an optional value. (In destination.)
- if (/^=(.*)/) {
- $type_val = $1;
- $_ = '';
- }
- # Nothing more is allowed after the command.
- &error("garbage '$_' after operand: $op")
- unless /^\s*$/;
- # Test that destination has no conditions.
- unless ($src) {
- error("condition not allowed in destination: $op")
- if $cond;
- error("variable name and type cannot be combined in destination: $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);
- }
- #
- # Generate code for all transformations.
- #
- sub tr_gen {
- my(@g) = @_;
- my($ref, $key, $instr); # Loop variables.
- 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);
- tr_gen_to($line, $orig_transform, $so_far, @$to_ref);
- }
- #
- # Print the generated transformation engine.
- #
- my($offset) = 0;
- print "Uint op_transform[] = {\n";
- foreach $key (sort keys %gen_transform) {
- $gen_transform_offset{$key} = $offset;
- my @instr = @{$gen_transform{$key}};
- #
- # If the last instruction is 'fail', remove it and
- # convert the previous 'try_me_else' to 'try_me_else_fail'.
- #
- if (is_instr($instr[$#instr], 'fail')) {
- pop(@instr);
- my $i = $#instr;
- $i-- while !is_instr($instr[$i], 'try_me_else');
- $instr[$i] = make_op('', 'try_me_else_fail');
- }
- foreach $instr (@instr) {
- my($size, $instr_ref, $comment) = @$instr;
- my($op, @args) = @$instr_ref;
- print " ";
- if (!defined $op) {
- $comment =~ s/\n(.)/\n $1/g;
- print "\n", $comment;
- } else {
- $op = "TOP_$op";
- $match_engine_ops{$op} = 1;
- if ($comment ne '') {
- printf "%-24s /* %s */\n", (join(", ", ($op, @args)) . ","),
- $comment;
- } else {
- print join(", ", ($op, @args)), ",\n";
- }
- $offset += $size;
- }
- }
- print "\n";
- }
- print "/*\n";
- print " * Total number of words: $offset\n";
- print " */\n";
- 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(%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;
- foreach $ref (@tr) {
- my($name, $arity, @ops) = @$ref;
- my($key) = "$name/$arity";
- my($opnum);
- $may_fail = 1 unless $is_first;
- $is_first = 0;
- #
- # A name starting with a period is a C pred function to be called.
- #
- if ($name =~ /^\.(\w+)/) {
- $name = $1;
- $may_fail = 1;
- my $var;
- my(@args);
- push(@fix_pred_funcs, scalar(@code));
- push(@code, [$name, @ops]);
- next;
- }
- #
- # Check that $name/$arity refers to a valid generic instruction.
- #
- &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)";
- if ($type ne '' && $type ne '*') {
- $may_fail = 1;
- #
- # The is_bif, is_not_bif, and is_func instructions have
- # their own built-in type test and don't need to
- # be guarded with a type test instruction.
- #
- $ignored_var = '';
- unless ($cond eq 'is_bif' or
- $cond eq 'is_not_bif' or
- $cond eq 'is_func') {
- my($types) = '';
- my($type_mask) = 0;
- foreach (split('', $type)) {
- $types .= "$_ ";
- $type_mask |= $type_bit{$_};
- }
- if ($cond ne 'is_eq') {
- push(@code, &make_op($types, 'is_type', $type_mask));
- } else {
- $cond = '';
- push(@code, &make_op("$types== $val", 'is_type_eq',
- $type_mask, $val));
- }
- }
- }
- if ($cond eq 'is_func') {
- my($m, $f, $a) = split(/:/, $val);
- $ignored_var = '';
- $may_fail = 1;
- push(@code, &make_op('', "$cond", "am_$m",
- "am_$f", $a));
- } elsif ($cond ne '') {
- $ignored_var = '';
- $may_fail = 1;
- 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}));
- } elsif ($type eq '*') {
- #
- # Reserve a hole for a 'rest_args' instruction.
- #
- $ignored_var = '';
- push(@fix_rest_args, scalar(@code));
- push(@code, $var);
- } elsif ($var_used{$var}) {
- $ignored_var = '';
- $var_type{$var} = 'scalar';
- $var{$var} = $var_num;
- $var_num++;
- push(@code, &make_op($var, 'set_var', $var{$var}));
- }
- }
- if (is_instr($code[$#code], 'set_var')) {
- my $ref = pop @code;
- my $comment = $ref->[2];
- my $var = $ref->[1][1];
- push(@code, make_op($comment, 'set_var_next_arg', $var));
- } else {
- push(@code, &make_op($ignored_var, 'next_arg'));
- }
- }
- # Remove redundant 'next_arg' instructions before the end
- # of the instruction.
- pop(@code) while is_instr($code[$#code], 'next_arg');
- }
- #
- # Insert the commit operation.
- #
- 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];
- }
- 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) = %$var_ref;
- my(%var_type) = %$var_type_ref;
- my(@code) = @$code_ref;
- my($op, $ref); # Loop variables.
- my($where) = "right side of transformation in line $line: ";
- my $last_instr = $code[$#code];
- my $cannot_fail = is_instr($last_instr, 'commit') &&
- (get_comment($last_instr) =~ /^always/);
- foreach $ref (@tr) {
- my($name, $arity, @ops) = @$ref;
- #
- # A name starting with a period is a C function to be called.
- #
- if ($name =~ /^\.(\w+)/) {
- $name = $1;
- my $var;
- my(@args);
- 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}");
- }
- }
- 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));
- last;
- }
- #
- # Check that $name/$arity refers to a valid generic instruction.
- #
- my($key) = "$name/$arity";
- &error($where, "invalid generic op $name/$arity")
- unless defined $gen_opnum{$name,$arity};
- my $opnum = $gen_opnum{$name,$arity};
- #
- # Create code to build the generic instruction.
- #
- push(@code, make_op("$name/$arity", 'new_instr', $opnum));
- foreach $op (@ops) {
- my($var, $type, $type_val) = @$op;
- if ($var ne '') {
- &error($where, "variable '$var' unbound")
- unless defined $var{$var};
- push(@code, &make_op($var, 'store_var_next_arg', $var{$var}));
- } elsif ($type ne '') {
- push(@code, &make_op('', 'store_type', "TAG_$type"));
- if ($type_val) {
- push(@code, &make_op('', 'store_val', $type_val));
- }
- push(@code, make_op('', 'next_arg'));
- }
- }
- pop(@code) if is_instr($code[$#code], 'next_arg');
- }
- push(@code, make_op('', 'end'))
- unless is_instr($code[$#code], 'call_end');
- #
- # Chain together all codes segments having the same first operation.
- #
- my($first_ref) = shift(@code);
- my($size, $first, $key) = @$first_ref;
- my($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}})
- if defined @{$gen_transform{$key}}; # Fail
- if ($prev_last && !is_instr($prev_last, 'fail')) {
- error("Line $line: A previous transformation shadows '$orig_transform'");
- }
- unless ($cannot_fail) {
- unshift(@code, make_op('', 'try_me_else',
- tr_code_len(@code)));
- push(@code, make_op(""), make_op("$key", 'fail'));
- }
- unshift(@code, make_op($comment));
- push(@{$gen_transform{$key}}, @code),
- }
- sub tr_code_len {
- my($sum) = 0;
- my($ref);
- foreach $ref (@_) {
- $sum += $$ref[0];
- }
- $sum;
- }
- sub make_op {
- my($comment, @op) = @_;
- [scalar(@op), [@op], $comment];
- }
- sub is_instr {
- my($ref,$op) = @_;
- return 0 unless ref($ref) eq 'ARRAY';
- $ref->[1][0] eq $op;
- }
- sub get_comment {
- my($ref,$op) = @_;
- return '' unless ref($ref) eq 'ARRAY';
- $ref->[2];
- }
- sub tr_next_index {
- my($lref,$href,$name,@args) = @_;
- my $code = "RVAL = $name(" . join(', ', 'st', @args) . "); break;\n";
- my $index;
- if (defined $$href{$code}) {
- $index = $$href{$code};
- } else {
- $index = scalar(@$lref);
- push(@$lref, $code);
- $$href{$code} = $index;
- }
- $index;
- }
- sub tr_gen_call {
- my(@call_table) = @_;
- my($i);
- for ($i = 0; $i < @call_table; $i++) {
- print "case $i: $call_table[$i]";
- }
- }