aboutsummaryrefslogtreecommitdiffstats
path: root/erts/emulator/utils/beam_makeops
diff options
context:
space:
mode:
Diffstat (limited to 'erts/emulator/utils/beam_makeops')
-rwxr-xr-xerts/emulator/utils/beam_makeops1500
1 files changed, 1500 insertions, 0 deletions
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops
new file mode 100755
index 0000000000..2b7e8a6dde
--- /dev/null
+++ b/erts/emulator/utils/beam_makeops
@@ -0,0 +1,1500 @@
+#!/usr/bin/env perl
+#
+# %CopyrightBegin%
+#
+# Copyright Ericsson AB 1998-2009. 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;
+
+# 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_shift[2] = ['0', 'BEAM_LOOSE_SHIFT'];
+$pack_shift[3] = ['0', 'BEAM_TIGHT_SHIFT', '(2*BEAM_TIGHT_SHIFT)'];
+
+$pack_mask[2] = ['BEAM_LOOSE_MASK', $WHOLE_WORD];
+$pack_mask[3] = ['BEAM_TIGHT_MASK', 'BEAM_TIGHT_MASK', 'BEAM_TIGHT_MASK'];
+
+# 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;
+
+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;
+
+#
+# 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 @pred_table;
+
+# Operand types for generic instructions.
+
+my $compiler_types = "uiaxyfhz";
+my $loader_types = "nprvlq";
+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
+ 'h' => 1, # character
+ 'l' => 1, # float reg
+ 'q' => 1, # literal term
+ );
+
+#
+# Generate bits.
+#
+my %type_bit;
+my @tag_type;
+
+{
+ my($bit) = 1;
+ my(%bit);
+
+ foreach (split('', $genop_types)) {
+ push(@tag_type, $_);
+ $type_bit{$_} = $bit;
+ $bit{$_} = $bit;
+ $bit *= 2;
+ }
+
+ # Composed types.
+ $type_bit{'d'} = $type_bit{'x'} | $type_bit{'y'} | $type_bit{'r'};
+ $type_bit{'c'} = $type_bit{'i'} | $type_bit{'a'} | $type_bit{'n'} | $type_bit{'q'};
+ $type_bit{'s'} = $type_bit{'d'} | $type_bit{'i'} | $type_bit{'a'} | $type_bit{'n'};
+ $type_bit{'j'} = $type_bit{'f'} | $type_bit{'p'};
+
+ # Aliases (for matching purposes).
+ $type_bit{'I'} = $type_bit{'u'};
+ $type_bit{'t'} = $type_bit{'u'};
+ $type_bit{'A'} = $type_bit{'u'};
+ $type_bit{'L'} = $type_bit{'u'};
+ $type_bit{'b'} = $type_bit{'u'};
+ $type_bit{'N'} = $type_bit{'u'};
+ $type_bit{'U'} = $type_bit{'u'};
+ $type_bit{'e'} = $type_bit{'u'};
+ $type_bit{'P'} = $type_bit{'u'};
+}
+
+#
+# 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/;
+ ($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($shift) = 16;
+ my($i);
+ for ($i = 0; $i < $max_spec_operands && defined $args[$i]; $i++) {
+ my $t = $args[$i];
+ if (defined $type_bit{$t}) {
+ $bits[int($i/2)] |= $type_bit{$t} << (16*($i%2));
+ }
+ }
+
+ 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 $tr != -1 or
+ $obsolete[$gen_opnum{$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_LOOSE_MASK 0x1FFFUL\n";
+ print "# define BEAM_TIGHT_MASK 0x1FF8UL\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(", &quote($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) -> {",
+ &quote($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 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. It was automatically\n";
+ print "$prefix generated by '$prog' on ", (scalar localtime), ".\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,
+ );
+
+ # 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 .= "Uint tmp_packed1;"
+ if $macro_code =~ /tmp_packed1/;
+ $var_decls .= "Uint tmp_packed2;"
+ if $macro_code =~ /tmp_packed2/;
+ if ($flags =~ /-nonext/) {
+ $code = "$macro_code\n";
+ } else {
+ $code = join("\n",
+ "{ $var_decls",
+ "Eterm* 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($i);
+ my($packable_args) = 0;
+
+ #
+ # Count the number of packable arguments. If we encounter any 's' or 'd'
+ # arguments, packing is not possible.
+ #
+ for ($i = 0; $i < @args; $i++) {
+ if ($args[$i] =~ /[xyt]/) {
+ $packable_args++;
+ } elsif ($args[$i] =~ /[sd]/) {
+ return ('', '', @args);
+ }
+ }
+
+ #
+ # 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) = $packable_args < 4 ? $packable_args : 2;
+ my(@shift) = @{$pack_shift[$args_per_word]};
+ my(@mask) = @{$pack_mask[$args_per_word]};
+ my(@pack_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 ($i = 0; $i < @args; $i++) {
+ my($reg) = $args[$i];
+ my($this_size) = $arg_size{$reg};
+ if ($reg =~ /[xyt]/) {
+ $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 = "$pack_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");
+ }
+
+ [$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 $so_far = tr_gen_from($line, @$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 (keys %gen_transform) {
+ $gen_transform_offset{$key} = $offset;
+ foreach $instr (@{$gen_transform{$key}}) {
+ 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 tr_gen_from {
+ 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: ";
+
+ foreach $ref (@tr) {
+ my($name, $arity, @ops) = @$ref;
+ my($key) = "$name/$arity";
+ my($opnum);
+
+ #
+ # A name starting with a period is a C pred function to be called.
+ #
+
+ if ($name =~ /^\.(\w+)/) {
+ $name = $1;
+ my $var;
+ my(@args);
+
+ my $next_instr = pop(@code); # Get rid of 'next_instr'
+ push(@fix_pred_funcs, scalar(@code));
+ push(@code, [$name, @ops]);
+ push(@code, $next_instr);
+ 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", 'is_op', $opnum));
+ $min_window++;
+ foreach $op (@ops) {
+ my($var, $type, $type_val, $cond, $val) = @$op;
+
+ if ($type ne '' && $type ne '*') {
+ my($types) = '';
+ my($type_mask) = 0;
+ foreach (split('', $type)) {
+ $types .= "$_ ";
+ $type_mask |= $type_bit{$_};
+ }
+ push(@code, &make_op($types, 'is_type', $type_mask));
+ }
+
+ if ($cond eq 'is_func') {
+ my($m, $f, $a) = split(/:/, $val);
+ push(@code, &make_op('', "$cond", "am_$m",
+ "am_$f", $a));
+ } elsif ($cond ne '') {
+ push(@code, &make_op('', "$cond", $val));
+ }
+
+ if ($var ne '') {
+ if (defined $var{$var}) {
+ push(@code, &make_op($var, 'is_same_var', $var{$var}));
+ } elsif ($type eq '*') {
+ #
+ # Reserve a hole for a 'rest_args' instruction.
+ #
+ push(@fix_rest_args, scalar(@code));
+ push(@code, $var);
+ } else {
+ $var_type{$var} = 'scalar';
+ $var{$var} = $var_num;
+ $var_num++;
+ push(@code, &make_op($var, 'set_var', $var{$var}));
+ }
+ }
+ if (is_set_var_instr($code[$#code])) {
+ 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('', 'next_arg'));
+ }
+ }
+ push(@code, &make_op('', 'next_instr'));
+ pop(@code) if $code[$#code]->[1][0] eq 'next_arg';
+ }
+
+ #
+ # Insert the commit operation.
+ #
+ pop(@code); # Get rid of 'next_instr'
+ push(@code, &make_op('', '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}");
+ }
+ }
+ splice(@code, $index, 1, &make_op("$name()",
+ 'pred', scalar(@pred_table)));
+ push(@pred_table, [$name, @args]);
+ }
+
+ $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: ";
+
+ 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 'next_instr'
+ push(@code, &make_op("$name()", 'call', scalar(@call_table)));
+ push(@call_table, [$name, @args]);
+ 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('', 'new_instr'));
+ push(@code, &make_op("$name/$arity", 'store_op', $opnum, $arity));
+ 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', $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 $code[$#code]->[1][0] eq 'next_arg';
+ }
+
+ push(@code, &make_op('', '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;
+
+ pop(@{$gen_transform{$key}})
+ if defined @{$gen_transform{$key}}; # Fail
+ my(@prefix) = (&make_op($comment), &make_op('', 'try_me_else', &tr_code_len(@code)));
+ unshift(@code, @prefix);
+ push(@{$gen_transform{$key}}, @code, &make_op('', 'fail'));
+}
+
+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_set_var_instr {
+ my($ref) = @_;
+ return 0 unless ref($ref) eq 'ARRAY';
+ $ref->[1][0] eq 'set_var';
+}
+
+sub tr_gen_call {
+ my(@call_table) = @_;
+ my($i);
+
+ print "\n";
+ for ($i = 0; $i < @call_table; $i++) {
+ my $ref = $call_table[$i];
+ my($name, @args) = @$ref;
+ print "case $i: RVAL = $name(", join(', ', 'st', @args), "); break;\n";
+ }
+ print "\n";
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-28 05:21:44 +0000