diff options
Diffstat (limited to 'erts/emulator/utils')
| -rwxr-xr-x | erts/emulator/utils/beam_makeops | 1500 | ||||
| -rwxr-xr-x | erts/emulator/utils/beam_strip | 89 | ||||
| -rwxr-xr-x | erts/emulator/utils/make_alloc_types | 672 | ||||
| -rwxr-xr-x | erts/emulator/utils/make_driver_tab | 71 | ||||
| -rwxr-xr-x | erts/emulator/utils/make_preload | 209 | ||||
| -rwxr-xr-x | erts/emulator/utils/make_tables | 368 | ||||
| -rwxr-xr-x | erts/emulator/utils/make_version | 63 | ||||
| -rw-r--r-- | erts/emulator/utils/mkver.c | 60 |
8 files changed, 3032 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(", "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 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"; +} diff --git a/erts/emulator/utils/beam_strip b/erts/emulator/utils/beam_strip new file mode 100755 index 0000000000..1ce0fea180 --- /dev/null +++ b/erts/emulator/utils/beam_strip @@ -0,0 +1,89 @@ +#!/usr/bin/env perl +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 2001-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; + +for (@ARGV) { + open(IN, "<$_") or do {warn "skipping $_:$!\n"; next}; + my $data; + sysread(IN, $data, 10000000); + close IN; + my $new_file = eval {slim_beam($data)}; + open(OUT, ">$_") or die "Failed to write $_:$!\n"; + print OUT $new_file; + close OUT; +} + +# Bug in 5.6.0: The following doesn't work. +#local $/; +#while (<>) { +# my $new_file = eval {slim_beam($_)}; +# if ($@) { +# ... +# } else { +# ... +# } +#} + +sub slim_beam { + my($beam) = @_; + my $size_left = length($beam); + my @chunk; + + die "can't read Beam files for OTP R4 or earlier (sorry)" + if $beam =~ /^\x7fBEAM!/; + + # + # Read and verify the head of the IFF file. + # + + my ($id, $size, $beam_id) = unpack("a4Na4", $beam); + die "not a BEAM file: no IFF 'FOR1' chunk" + unless $id eq 'FOR1'; + $size_left -= 8; + die "form size $size greater than size ", $size_left, " of module" + if $size > $size_left; + $size_left -= 4; + die "not a BEAM file: IFF form type is not 'BEAM'" + unless $beam_id eq 'BEAM'; + + # + # Read all IFF chunks. + # + + $beam = substr($beam, 12, $size_left); + while ($size_left > 0) { + ($id, $size) = unpack("a4N", $beam); + $size_left -= 8; + die "chunk size $size greater than size ", $size_left, " of module" + if $size > $size_left; + $size = 4*int(($size+3)/4); + my $chunk = substr($beam, 0, $size+8); + $beam = substr($beam, 8+$size); + $size_left = length($beam); + push(@chunk, $chunk) + unless $id eq 'LocT' || $id eq 'CInf'; + } + + # + # Create new Beam file. + # + my $new_file = join('', @chunk); + "FOR1" . pack("N", length($new_file)+4) . "BEAM" . $new_file; +} diff --git a/erts/emulator/utils/make_alloc_types b/erts/emulator/utils/make_alloc_types new file mode 100755 index 0000000000..53051b7692 --- /dev/null +++ b/erts/emulator/utils/make_alloc_types @@ -0,0 +1,672 @@ +#!/usr/bin/env perl +# -*- cperl -*- + +# %CopyrightBegin% +# +# Copyright Ericsson AB 2003-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 warnings; + +use File::Basename; + +# +# Description: +# Generates a header file containing defines for memory allocation types +# from type declarations in a config file. +# +# Usage: +# make_alloc_types -src <config-file> -dst <c-header-file> +# +# Options: +# -src <config-file> +# -dst <c-header-file> +# [<enabled-boolean-variable> ...] +# +# Author: Rickard Green +# + +my $myname = basename($0); +my $src; +my $dst; +my %bool_vars; + +while (@ARGV && $ARGV[0]) { + my $opt = shift; + if ($opt eq '-src') { + $src = shift; + $src or die "$myname: Missing source file\n"; + } elsif ($opt eq '-dst') { + $dst = shift; + $dst or die "$myname: Missing destination file\n"; + } else { + $bool_vars{$opt} = 'true'; + } +} + +$src or usage("Missing source file"); +$dst or usage("Missing destination file"); + +open(SRC, "<$src") or die "$myname: Failed to open $src in read mode\n"; + +my $line; +my $line_no = 0; +my $decl; + +my %a_tab; +my %c_tab; +my %t_tab; +my %d_tab; +my @a_order; +my @c_order; +my @t_order; + +my @cond_stack; + +############################################################################# +# Parse source file +############################################################################# + +while ($line = <SRC>) { + $line_no = $line_no + 1; + $line = preprocess_line($line); + + if ($line =~ /^(\S+)\s*(.*)/) { + $decl = $1; + $line = $2; + + if ($decl eq 'type') { + if ($line =~ /^(\w+)\s+(\w+)\s+(\w+)\s+(\w+)\s*$/) { + my $t = $1; + my $a = $2; + my $c = $3; + my $d = $4; + + check_reserved_words('type', $t, $d); + + my $a_entry = $a_tab{$a}; + $a_entry or src_error("No allocator '$a' declared"); + my $c_entry = $c_tab{$c}; + $c_entry or src_error("No class '$c' declared"); + + !$t_tab{$t} or src_error("Type '$t' already declared"); + my $d_user = $d_tab{$d}; + !$d_user or duplicate_descr($d, $d_user); + + $t_tab{$t} = mk_entry($d, $a, $c); + add_type($a_entry, $t); + + $d_tab{$d} = "type '$t'"; + + } else { + invalid_decl($decl); + } + } elsif ($decl eq 'allocator') { + if ($line =~ /^(\w+)\s+(\w+)\s+(\w+)\s*$/) { + my $a = $1; + my $mt = $2; + my $d = $3; + + check_reserved_words('allocator', $a, $d); + + !$a_tab{$a} or src_error("Allocator '$a' already declared"); + my $d_user = $d_tab{$d}; + !$d_user or duplicate_descr($d, $d_user); + + my $e = mk_entry($d); + $a_tab{$a} = $e; + + if ($mt =~ /^true$/) { + set_multi_thread($e); + } + else { + $mt =~ /^false$/ or src_error("Multi-thread option not a boolean"); + } + + $d_tab{$d} = "allocator '$a'"; + + push(@a_order, $a); + + } else { + invalid_decl($decl); + } + } elsif ($decl eq 'class') { + if ($line =~ /^(\w+)\s+(\w+)\s*$/) { + my $c = $1; + my $d = $2; + + check_reserved_words('class', $c, $d); + + !$c_tab{$c} or src_error("Class '$c' already declared"); + my $d_user = $d_tab{$d}; + !$d_user or duplicate_descr($d, $d_user); + + $c_tab{$c} = mk_entry($d); + + $d_tab{$d} = "class '$c'"; + + } else { + invalid_decl($decl); + } + } else { + src_error("Unknown '$decl' declaration found"); + } + } +} + +close(SRC) or warn "$myname: Error closing $src"; + +check_cond_stack(); + +############################################################################# +# Create destination file +############################################################################# + +mkdir(dirname($dst), 0777); +open(DST, ">$dst") or die "$myname: Failed to open $dst in write mode\n"; + +print DST "/* + * ----------------------------------------------------------------------- + * + * NOTE: Do *not* edit this file; instead, edit '", basename($src),"' and + * build again! This file was automatically generated by + * '$myname' on ", (scalar localtime), ". + * + * ----------------------------------------------------------------------- + * + * + * Copyright Ericsson AB ", (1900 + (localtime)[5]), ". 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. + * + */ + +#ifndef ERL_ALLOC_TYPES_H__ +#define ERL_ALLOC_TYPES_H__ + +"; + +my $a_no = 1; +my $c_no = 1; +my $t_no = 1; + +# Print allocator numbers ------------------------------------------------- + +print DST " +/* --- Allocator numbers -------------------------------------------------- */ + +#define ERTS_ALC_A_INVALID (0) + +"; + +print DST "#define ERTS_ALC_A_MIN ($a_no)\n\n"; + +foreach my $a (@a_order) { + set_number($a_tab{$a}, $a_no); + print DST "#define ERTS_ALC_A_$a ($a_no)\n"; + $a_no++; +} +$a_no--; + +print DST "\n#define ERTS_ALC_A_MAX ($a_no)\n"; + +# Print class numbers ----------------------------------------------------- + +print DST " + +/* --- Class numbers ------------------------------------------------------ */ + +#define ERTS_ALC_C_INVALID (0) + +"; + +print DST "#define ERTS_ALC_C_MIN ($c_no)\n\n"; + +foreach my $c (keys(%c_tab)) { + push(@c_order, $c); + set_number($c_tab{$c}, $c_no); + print DST "#define ERTS_ALC_C_$c ($c_no)\n"; + $c_no++; +} +$c_no--; +print DST "\n#define ERTS_ALC_C_MAX ($c_no)\n"; + +# Print type number intervals --------------------------------------------- + +print DST " + +/* --- Type number intervals ---------------------------------------------- */ + +#define ERTS_ALC_N_INVALID (0) + +"; + +print DST "#define ERTS_ALC_N_MIN ($t_no)\n\n"; + +foreach my $a (@a_order) { + my $a_entry = $a_tab{$a}; + my $ts = get_types($a_entry); + my $n_ts = @{$ts}; + if ($n_ts > 0) { + + print DST "/* Type numbers used for ", get_description($a_entry), " */\n"; + print DST "#define ERTS_ALC_N_MIN_A_$a ($t_no)\n"; + + foreach my $t (@{$ts}) { + push(@t_order, $t); + set_number($t_tab{$t}, $t_no); +# print DST "#define ERTS_ALC_N_$t ($t_no)\n"; + $t_no++; + } + + print DST "#define ERTS_ALC_N_MAX_A_$a (", $t_no - 1, ")\n\n"; + } + else { + print DST "/* No types use ", get_description($a_entry), " */\n\n"; + } +} +$t_no--; +print DST "#define ERTS_ALC_N_MAX ($t_no)\n"; + +# Print multi thread use of allocators ------------------------------------- + +print DST " + +/* --- Multi thread use of allocators -------------------------------------- */ + +"; + +foreach my $a (@a_order) { + my $mt = get_multi_thread($a_tab{$a}); + print DST "#define ERTS_ALC_MTA_$a (", $mt ? "1" : "0" ,")\n"; +} + + +# Calculate field sizes, masks, and shifts needed -------------------------- + +my $a_bits = fits_in_bits($a_no); +my $c_bits = fits_in_bits($c_no); +my $n_bits = fits_in_bits($t_no); +my $t_bits = $a_bits + $n_bits + $c_bits; + +$n_bits <= 16 + # Memory trace format expects type numbers to fit into an Uint16 + or die("$myname: ", $t_no + 1, " types declared;", + " maximum number of types allowed are ", (1 << 16),"\n"); + +$t_bits <= 24 + # We want 8 bits for flags (we actually only use 1 bit for flags + # at the time of writing)... + or die("$myname: More allocators, classes, and types declared than ", + "allowed\n"); + +my $a_mask = (1 << $a_bits) - 1; +my $c_mask = (1 << $c_bits) - 1; +my $n_mask = (1 << $n_bits) - 1; +my $t_mask = (1 << $t_bits) - 1; + +my $a_shift = 0; +my $c_shift = $a_bits + $a_shift; +my $n_shift = $c_bits + $c_shift; + + +# Print the types ---------------------------------------------------------- + +print DST " + +/* --- Types --------------------------------------------------------------- */ + +typedef Uint32 ErtsAlcType_t; /* The type used for memory types */ + +#define ERTS_ALC_T_INVALID (0) + +"; + +foreach my $t (@t_order) { + print DST + "#define ERTS_ALC_T_$t (", + ((get_number($a_tab{get_allocator($t_tab{$t})}) << $a_shift) + | (get_number($c_tab{get_class($t_tab{$t})}) << $c_shift) + | (get_number($t_tab{$t}) << $n_shift)), + ")\n"; +} + + + +# Print field sizes, masks, and shifts needed ------------------------------ + +print DST " + +/* --- Field sizes, masks, and shifts -------------------------------------- */ + +#define ERTS_ALC_A_BITS ($a_bits) +#define ERTS_ALC_C_BITS ($c_bits) +#define ERTS_ALC_N_BITS ($n_bits) +#define ERTS_ALC_T_BITS ($t_bits) + +#define ERTS_ALC_A_MASK ($a_mask) +#define ERTS_ALC_C_MASK ($c_mask) +#define ERTS_ALC_N_MASK ($n_mask) +#define ERTS_ALC_T_MASK ($t_mask) + +#define ERTS_ALC_A_SHIFT ($a_shift) +#define ERTS_ALC_C_SHIFT ($c_shift) +#define ERTS_ALC_N_SHIFT ($n_shift) +"; + +# Print mappings needed ---------------------------------------------------- + +print DST " + +/* --- Mappings ------------------------------------------------------------ */ + +/* type -> type number */ +#define ERTS_ALC_T2N(T) (((T) >> ERTS_ALC_N_SHIFT) & ERTS_ALC_N_MASK) + +/* type -> allocator number */ +#define ERTS_ALC_T2A(T) (((T) >> ERTS_ALC_A_SHIFT) & ERTS_ALC_A_MASK) + +/* type -> class number */ +#define ERTS_ALC_T2C(T) (((T) >> ERTS_ALC_C_SHIFT) & ERTS_ALC_C_MASK) + +/* type number -> type */ +#define ERTS_ALC_N2T(N) (erts_alc_n2t[(N)]) + +/* type number -> type description */ +#define ERTS_ALC_N2TD(N) (erts_alc_n2td[(N)]) + +/* type -> type description */ +#define ERTS_ALC_T2TD(T) (ERTS_ALC_N2TD(ERTS_ALC_T2N((T)))) + +/* class number -> class description */ +#define ERTS_ALC_C2CD(C) (erts_alc_c2cd[(C)]) + +/* allocator number -> allocator description */ +#define ERTS_ALC_A2AD(A) (erts_alc_a2ad[(A)]) + +extern const ErtsAlcType_t erts_alc_n2t[]; +extern const char *erts_alc_n2td[]; +extern const char *erts_alc_c2cd[]; +extern const char *erts_alc_a2ad[]; + +#ifdef ERTS_ALC_INTERNAL__ + +const ErtsAlcType_t erts_alc_n2t[] = { + ERTS_ALC_T_INVALID, +"; + +foreach my $t (@t_order) { + print DST " ERTS_ALC_T_$t,\n"; +} + +print DST " ERTS_ALC_T_INVALID +}; + +const char *erts_alc_n2td[] = { + \"invalid_type\", +"; + +foreach my $t (@t_order) { + print DST " \"", get_description($t_tab{$t}), "\",\n"; +} + +print DST " NULL +}; + +const char *erts_alc_c2cd[] = { + \"invalid_class\", +"; + +foreach my $c (@c_order) { + print DST " \"", get_description($c_tab{$c}), "\",\n"; +} + +print DST " NULL +}; + +const char *erts_alc_a2ad[] = { + \"invalid_allocator\", +"; + +foreach my $a (@a_order) { + print DST " \"", get_description($a_tab{$a}), "\",\n"; +} + +print DST " NULL +}; +"; + +print DST " +#endif /* #ifdef ERTS_ALC_INTERNAL__ */ +"; + +# End of DST +print DST " + +/* ------------------------------------------------------------------------- */ +#endif /* #ifndef ERL_ALLOC_TYPES_H__ */ +"; + + +close(DST) or warn "$myname: Error closing $dst"; + +exit; + +############################################################################# +# Help routines +############################################################################# + +sub fits_in_bits { + my $val = shift; + my $bits; + + $val >= 0 or die "Expected value >= 0; got $val"; + + $bits = 0; + + while ($val != 0) { + $val >>= 1; + $bits++; + } + + return $bits; +} + +############################################################################# +# Table entries +# + +sub mk_entry { + my $d = shift; + my $a = shift; + my $c = shift; + return [$d, undef, [], $a, $c, undef]; +} + +sub get_description { + my $entry = shift; + return $entry->[0]; +} + +sub get_number { + my $entry = shift; + return $entry->[1]; +} + +sub get_types { + my $entry = shift; + return $entry->[2]; +} + +sub get_allocator { + my $entry = shift; + return $entry->[3]; +} + +sub get_class { + my $entry = shift; + return $entry->[4]; +} + +sub set_number { + my $entry = shift; + my $number = shift; + $entry->[1] = $number; +} + +sub add_type { + my $entry = shift; + my $t = shift; + push(@{$entry->[2]}, $t); +} + +sub set_multi_thread { + my $entry = shift; + $entry->[5] ='true'; +} + +sub get_multi_thread { + my $entry = shift; + return $entry->[5]; +} + +############################################################################# +# Preprocessing of a line + +sub preprocess_line { + my $line = shift; + $line =~ s/#.*$//; + $line =~ /^\s*(.*)$/; + $line = $1; + + if (!@cond_stack) { + push(@cond_stack, [undef, undef, undef, 'true', undef]); + } + + my $see_line = $cond_stack[@cond_stack - 1]->[3]; + + if ($line =~ /^(\S+)(.*)$/) { + my $ifdefop = $1; + my $ifdefarg = $2; + + if ($ifdefop eq '+if') { + $ifdefarg =~ /^\s*(\w+)\s*$/ or src_error("Bad '+if'"); + my $var = $1; + if ($see_line) { + $see_line = $bool_vars{$var}; + } + push(@cond_stack, ['+if', $var, undef, $see_line, $line_no]); + $see_line = undef; + } + elsif ($ifdefop eq '+ifnot') { + $ifdefarg =~ /^\s*(\w+)\s*$/ or src_error("Bad '+ifnot'"); + my $var = $1; + if ($see_line) { + $see_line = !$bool_vars{$var}; + } + push(@cond_stack, ['+ifnot', $var, undef, $see_line, $line_no]); + $see_line = undef; + } + elsif ($ifdefop eq '+else') { + $ifdefarg =~ /^\s*$/ or src_error("Garbage after '+else'"); + my $val = $cond_stack[@cond_stack - 1]; + $val->[0] or src_error("'+else' not matching anything"); + !$val->[2] or src_error("duplicate '+else'"); + $val->[2] = 'else'; + if ($see_line || $cond_stack[@cond_stack - 2]->[3]) { + $val->[3] = !$val->[3]; + } + $see_line = undef; + } + elsif ($ifdefop eq '+endif') { + $ifdefarg =~ /^\s*$/ or src_error("Garbage after '+endif'"); + my $val = pop(@cond_stack); + $val->[0] or src_error("'+endif' not matching anything"); + $see_line = undef; + } + elsif ($see_line) { + if ($ifdefop eq '+enable') { + $ifdefarg =~ /^\s*(\w+)\s*$/ or src_error("Bad '+enable'"); + $bool_vars{$1} = 'true'; + $see_line = undef; + } + elsif ($ifdefop eq '+disable') { + $ifdefarg =~ /^\s*(\w+)\s*$/ or src_error("Bad '+disable'"); + $bool_vars{$1} = undef; + $see_line = undef; + } + } + } + + return $see_line ? $line : ""; +} + +sub check_cond_stack { + my $val = $cond_stack[@cond_stack - 1]; + if ($val->[0]) { + $line_no = $val->[4]; + src_error("'", $val->[0], " ", $val->[1], "' not terminated\n"); + } +} + +sub check_reserved_words { + my $sort = shift; + my $name = shift; + my $descr = shift; + + !($name eq 'INVALID') + or src_error("Reserved $sort 'INVALID' declared"); + !($descr eq 'invalid_allocator') + or src_error("Reserved description 'invalid_allocator' used"); + !($descr eq 'invalid_class') + or src_error("Reserved description 'invalid_class' used"); + !($descr eq 'invalid_type') + or src_error("Reserved description 'invalid_type' used"); +} + +############################################################################# +# Error cases + +sub usage { + warn "$myname: ", @_, "\n"; + die "Usage: $myname -src <source> -dst <destination> [<var> ...]\n"; +} + +sub src_error { + die "$src:$line_no: ", @_, "\n"; +} + +sub duplicate_descr { + my $d = shift; + my $u = shift; + src_error("Description '$d' already used for '$u'"); +} + +sub invalid_decl { + my $decl = shift; + src_error("Invalid '$decl' declaration"); +} + +############################################################################# diff --git a/erts/emulator/utils/make_driver_tab b/erts/emulator/utils/make_driver_tab new file mode 100755 index 0000000000..fbbfa3e49e --- /dev/null +++ b/erts/emulator/utils/make_driver_tab @@ -0,0 +1,71 @@ +#!/usr/bin/env perl +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1999-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 File::Basename; + +# This program generates driver_tab.c which holds the driver_tab +# array. Since the contents of driver_tab will depend on which +# drivers we wish to include it has to be generated. + +# usage: make_driver_tab [-o filename] drivers... + +my $file = ""; +my @drivers = (); + +while (@ARGV) { + my $d = shift; + if ( $d =~ /^-o$/ ) { + $file = shift or die("-o requires argument"); + next; + } + $d = basename $d; + $d =~ s/drv(\..*|)$//; # strip drv.* or just drv + push(@drivers, $d); +} + +# Did we want output to a file? +if ( $file ) { + open(STDOUT, ">$file") or die("can't open $file for writing"); +} + +print <<EOF; +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif /* HAVE_CONFIG_H */ +#include <stdio.h> +#include "global.h" + +EOF + +# "extern" declarations +foreach (@drivers) { + print "extern ErlDrvEntry ${_}driver_entry;\n"; +} + +# The array itself +print "\nErlDrvEntry *driver_tab[DRIVER_TAB_SIZE] =\n{\n"; + +foreach (@drivers) { + print " &${_}driver_entry,\n"; +} + +print " NULL\n};\n"; + +# That's it diff --git a/erts/emulator/utils/make_preload b/erts/emulator/utils/make_preload new file mode 100755 index 0000000000..d0671e998d --- /dev/null +++ b/erts/emulator/utils/make_preload @@ -0,0 +1,209 @@ +#!/usr/bin/env perl +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1999-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 File::Basename; + +# +# Description: +# Packages one erlang module in a form that can be preloaded (C source +# for Unix or resource script for Windows). The output is written to +# standard output. +# +# Usage: +# make_preload [ Options ] file.{jam,beam} +# +# Options: +# -rc Produce a resource script rather than C source. +# +# Author: +# Bjorn Gustavsson +# + +my $gen_rc = 0; +my $gen_old = 0; +my $windres = 0; +my $file; + +my $progname = basename($0); + +while (@ARGV && $ARGV[0] =~ /^-(\w+)/) { + my $opt = shift; + if ($opt eq '-rc') { + $gen_rc = 1; + } elsif ($opt eq '-windres') { + $windres = 1; + } elsif ($opt eq '-old') { + $gen_old = 1; + } else { + usage("bad option: $opt"); + } +} + +print header(); + +my @modules; +my $num = 1; + +foreach $file (@ARGV) { + local($/); + + usage("not a beam file") + unless $file =~ /\.beam$/; + my $module = basename($file, ".beam"); + if ($gen_rc) { + my ($win_file) = split("\n", `(cygpath -d $file 2>/dev/null || cygpath -w $file)`); + $win_file =~ s&\\&\\\\&g; + print "$num ERLANG_CODE \"$win_file\"\n"; + push(@modules, " ", -s $file, "L, $num, ", + length($module), ",\"$module\",\n"); + $num++; + } else { + my $i; + my $comment = ''; + + open(FILE, $file) or error("failed to read $file: $!"); + $_ = <FILE>; + $_ = beam_strip($_); + close(FILE); + + push(@modules, " {\"$module\", " . length($_) . ", preloaded_$module},\n"); + print "unsigned preloaded_size_$module = ", length($_), ";\n"; + print "unsigned char preloaded_$module", "[] = {\n"; + for ($i = 0; $i < length($_); $i++) { + if ($i % 8 == 0 && $comment ne '') { + $comment =~ s@\*/@..@g; # Comment terminator. + print " /* $comment */\n "; + $comment = ''; + } + my $c = ord(substr($_, $i, 1)); + printf("0x%02x,", $c); + $comment .= (32 <= $c && $c < 127) ? chr($c) : '.'; + } + $comment =~ s@\*/@..@g; # Comment terminator. + print " " x (8-($i % 8)), " /* $comment */\n};\n"; + } +} + +if ($windres) { + $modules[$#modules] =~ s/,$//; +} + +if ($gen_rc) { + print "#include <beam.rc>\n"; + $num--; + print "\n0 ERLANG_DICT\n"; + print "BEGIN\n"; + print " $num,\n"; + print @modules; + print "END\n"; +} elsif ($gen_old) { + print "struct {\n"; + print " char* name;\n"; + print " int size;\n"; + print " unsigned char* code;\n"; + print "} pre_loaded[] = {\n"; + foreach (@modules) { + print; + } + print " {0, 0, 0}\n"; + print "};\n"; +} + +sub usage { + warn "$progname: ", @_, "\n"; + die "usage: $progname -o output-directory file.{jam,beam}\n"; +} + +sub error { + die "$progname: ", @_, "\n"; +} + +sub beam_strip { + my($beam) = @_; + + + my $size_left = length($beam); + my %chunk; + my %needed_chunk = ('Code' => 1, + 'Atom' => 1, + 'ImpT' => 1, + 'ExpT' => 1, + 'StrT' => 1, + 'FunT' => 1, + 'LitT' => 1); + + die "can't read Beam files for OTP R4 or earlier (sorry)" + if $beam =~ /^\x7fBEAM!/; + + # + # Read and verify the head of the IFF file. + # + + my ($id, $size, $beam_id) = unpack("a4Na4", $beam); + + return $beam # It might be compressed. + unless $id eq 'FOR1'; +# die "not a BEAM file: no IFF 'FOR1' chunk" +# unless $id eq 'FOR1'; + $size_left -= 8; + die "form size $size greater than size ", $size_left, " of module" + if $size > $size_left; + $size_left -= 4; + die "not a BEAM file: IFF form type is not 'BEAM'" + unless $beam_id eq 'BEAM'; + + # + # Read all IFF chunks. + # + + $beam = substr($beam, 12, $size_left); + while ($size_left > 0) { + ($id, $size) = unpack("a4N", $beam); + $size_left -= 8; + die "chunk size $size greater than size ", $size_left, " of module" + if $size > $size_left; + $size = 4*int(($size+3)/4); + $chunk{$id} = substr($beam, 0, 8+$size); + $beam = substr($beam, 8+$size); + $size_left = length($beam); + } + + # + # Create a new beam file with only the useful chunk types. + # + + my @chunks; + foreach (sort keys %chunk) { + push(@chunks, $chunk{$_}) + if $needed_chunk{$_}; + } + $beam = join('', @chunks); + join('', "FOR1", pack("N", length($beam)+4), "BEAM", $beam); +} + +sub header { + my $time = localtime; + <<END; +/* + * DO NOT EDIT THIS FILE. It was automatically generated + * by the `$progname' program on $time. + */ +END +} diff --git a/erts/emulator/utils/make_tables b/erts/emulator/utils/make_tables new file mode 100755 index 0000000000..b5391234cf --- /dev/null +++ b/erts/emulator/utils/make_tables @@ -0,0 +1,368 @@ +#!/usr/bin/env perl +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1999-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 File::Basename; + +# +# Description: +# Creates tables for BIFs and atoms. +# +# Usage: +# make_tables [ Options ] file... +# +# Options: +# -src directory Where to write generated C source files (default "."). +# -include directory Where to generate generated C header files (default "."). +# +# Output: +# <-src>/erl_am.c +# <-src>/erl_bif_table.c +# <-src>/erl_bif_wrap.c +# <-src>/erl_pbifs.c +# <-include>/erl_atom_table.h +# <-include>/erl_bif_table.h +# +# Author: Bjorn Gustavsson +# + +my $progname = basename($0); +my $src = '.'; +my $include = '.'; + +my @atom; +my %atom; +my %atom_alias; +my %aliases; +my $auto_alias_num = 0; + +my @bif; +my @implementation; +my @pbif; + +while (@ARGV && $ARGV[0] =~ /^-(\w+)/) { + my $opt = shift; + if ($opt eq '-src') { + $src = shift; + die "No directory for -src argument specified" + unless defined $src; + } elsif($opt eq '-include') { + $include = shift; + die "No directory for -include argument specified" + unless defined $include; + } else { + usage("bad option: $opt"); + } +} + + +while (<>) { + next if /^#/; + next if /^\s*$/; + my($type, @args) = split; + if ($type eq 'atom') { + save_atoms(@args); + } elsif ($type eq 'bif' or $type eq 'ubif') { + my($bif,$alias,$alias2) = (@args); + $bif =~ m@^([a-z_.'0-9]+):(.*)/(\d)$@ or error("invalid BIF"); + my($mod,$name,$arity) = ($1,$2,$3); + save_atoms($mod, $name); + unless (defined $alias) { + $alias = ""; + $alias = "${mod}_" unless $mod eq 'erlang'; + $alias .= "${name}_$arity"; + } + my $wrapper; + $wrapper = "wrap_$alias" if $type eq 'bif'; + $wrapper = $alias if $type eq 'ubif'; + push(@bif, ["am_$atom_alias{$mod}","am_$atom_alias{$name}",$arity, + $alias,$wrapper]); + push(@pbif, $bif =~ m/^'/ && $alias =~ m/^ebif_/); + push(@implementation, $alias2); + } else { + error("invalid line"); + } +} continue { + close ARGV if eof; +} + +# +# Generate the atom header file. +# + +open_file("$include/erl_atom_table.h"); +print <<EOF; +#ifndef __ERL_ATOM_TABLE_H__ +#define __ERL_ATOM_TABLE_H__ +extern char* erl_atom_names[]; + +EOF +my $i; +for ($i = 0; $i < @atom; $i++) { + my $alias = $atom_alias{$atom[$i]}; + print "#define am_$alias make_atom($i)\n" + if defined $alias; +} +print "#endif\n"; + +# +# Generate the atom table file. +# + +open_file("$src/erl_atom_table.c"); +my $i; +print "char* erl_atom_names[] = {\n"; + +for ($i = 0; $i < @atom; $i++) { + print ' "', $atom[$i], '",', "\n"; +} +print " 0\n"; +print "};\n"; + +# +# Generate the generic bif list file. +# + +open_file("$include/erl_bif_list.h"); +my $i; +for ($i = 0; $i < @bif; $i++) { + # module atom, function atom, arity, C function, table index + print "BIF_LIST($bif[$i]->[0],$bif[$i]->[1],$bif[$i]->[2],$bif[$i]->[3],$i)\n"; +} + +# +# Generate the bif header file. +# + +open_file("$include/erl_bif_table.h"); +my $bif_size = @bif; +print <<EOF; +#ifndef __ERL_BIF_TABLE_H__ +#define __ERL_BIF_TABLE_H__ +typedef void *BifFunction; + +typedef struct bif_entry { + Eterm module; + Eterm name; + int arity; + BifFunction f; + BifFunction traced; +} BifEntry; + +extern BifEntry bif_table[]; +extern Export* bif_export[]; +extern unsigned char erts_bif_trace_flags[]; + +#define BIF_SIZE $bif_size + +EOF + +my $i; +for ($i = 0; $i < @bif; $i++) { + print "#define BIF_$bif[$i]->[3] $i\n"; +} + +print "\n"; + +for ($i = 0; $i < @bif; $i++) { + my $arity = $bif[$i]->[2]; + my $args = join(', ', 'Process*', ('Eterm') x $arity); + print "Eterm $bif[$i]->[3]($args);\n"; + print "Eterm wrap_$bif[$i]->[3]($args, Uint *I);\n"; +} +print "#endif\n"; + +# +# Generate the bif table file. +# + +open_file("$src/erl_bif_table.c"); +my $i; +includes("export.h", "sys.h", "erl_vm.h", "erl_process.h", "bif.h", + "erl_bif_table.h", "erl_atom_table.h"); + +print "\nExport* bif_export[BIF_SIZE];\n"; +print "unsigned char erts_bif_trace_flags[BIF_SIZE];\n\n"; + +print "BifEntry bif_table[] = {\n"; +for ($i = 0; $i < @bif; $i++) { + my $func = $bif[$i]->[3]; + print " {", join(', ', @{$bif[$i]}), "},\n"; +} +print "};\n\n"; + +# +# Generate the bif wrappers file. +# + +open_file("$src/erl_bif_wrap.c"); +my $i; +includes("export.h", "sys.h", "erl_vm.h", "global.h", "erl_process.h", "bif.h", + "erl_bif_table.h", "erl_atom_table.h"); +for ($i = 0; $i < @bif; $i++) { + next if $bif[$i]->[3] eq $bif[$i]->[4]; # Skip unwrapped bifs + my $arity = $bif[$i]->[2]; + my $func = $bif[$i]->[3]; + my $arg; + print "Eterm\n"; + print "wrap_$func(Process* p"; + for ($arg = 1; $arg <= $arity; $arg++) { + print ", Eterm arg$arg"; + } + print ", Uint *I)\n"; + print "{\n"; + print " return erts_bif_trace($i, p"; + for ($arg = 1; $arg <= 3; $arg++) { + if ($arg <= $arity) { + print ", arg$arg"; + } elsif ($arg == ($arity + 1)) { + # Place I in correct position + print ", (Eterm) I"; + } else { + print ", 0"; + } + } + # I is always last, as well as in the correct position + # Note that "last" and "correct position" may be the same... + print ", I);\n"; + print "}\n\n"; +} + +# +# Generate the package bif file. +# + +open_file("$src/erl_pbifs.c"); +my $i; +includes("export.h", "sys.h", "erl_vm.h", "global.h", "erl_process.h", "bif.h", + "erl_bif_table.h", "erl_atom_table.h"); +for ($i = 0; $i < @bif; $i++) { + my $arity = $bif[$i]->[2]; + my $func = $bif[$i]->[3]; + my $arg; + next unless $pbif[$i]; + next unless $func =~ m/^ebif_(.*)/; + my $orig_func = $1; + $orig_func = $implementation[$i] if $implementation[$i]; + print "Eterm\n"; + print "$func(Process* p"; + for ($arg = 1; $arg <= $arity; $arg++) { + print ", Eterm arg$arg"; + } + print ")\n"; + print "{\n"; + print " return $orig_func(p"; + for ($arg = 1; $arg <= 3; $arg++) { + if ($arg <= $arity) { + print ", arg$arg"; + } + } + print ");\n"; + print "}\n\n"; +} + +sub open_file { # or die + my($name) = @_; + + open(FILE, ">$name") or die "$0: Failed to create $name: $!\n"; + select(FILE); + comment('C'); +} + +sub includes { + print "#ifdef HAVE_CONFIG_H\n"; + print "# include \"config.h\"\n"; + print "#endif /* HAVE_CONFIG_H */\n"; + print map { "#include \"$_\"\n"; } @_; + print "\n"; +} + +sub save_atoms { + my $atom; + my $alias; + + foreach $atom (@_) { + if ($atom =~ /^\w+$/) { + error("$atom: an atom must start with a lowercase letter\n", + " (use an alias like this: $atom='$atom')") + unless $atom =~ /^[a-z]/; + $alias = $atom; + } elsif ($atom =~ /^'(.*)'$/) { + $atom = $1; + $alias = "_AtomAlias$auto_alias_num"; + $auto_alias_num++; + } elsif ($atom =~ /^(\w+)='(.*)'$/) { + $alias = $1; + $atom = $2; + error("$alias: an alias must start with an uppercase letter") + unless $alias =~ /^[A-Z]/; + } else { + error("invalid atom: $atom"); + } + next if $atom{$atom}; + push(@atom, $atom); + $atom{$atom} = 1; + + if (defined $alias) { + error("$alias: this alias is already in use") + if defined $aliases{$alias} && $aliases{$alias} ne $atom; + $aliases{$alias} = $atom; + $atom_alias{$atom} = $alias; + } + } +} + +sub usage { + warn "$progname: ", @_, "\n"; + die "usage: $progname -src source-dir -include include-dir file...\n"; +} + +sub error { + die "$ARGV($.): ", @_, "\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 '$progname' on ", (scalar localtime), ".\n"; + } + if ($lang eq 'C') { + print " */\n"; + } + print "\n"; +} diff --git a/erts/emulator/utils/make_version b/erts/emulator/utils/make_version new file mode 100755 index 0000000000..7757fa8138 --- /dev/null +++ b/erts/emulator/utils/make_version @@ -0,0 +1,63 @@ +#!/usr/bin/env perl +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1999-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; + +# Create the file erl_version.h +# +# Usage: +# make_version [ -o outputfile ] version architecture +# +# Output goes to ./erl_version.h (or to "outputfile" if specified) +# + +my $time_str = localtime; +my $outputfile = "erl_version.h"; + +@ARGV or die "No arguments given to 'make_version'"; + +if ($ARGV[0] eq '-o') { + shift; # Remove -o + $outputfile = shift; + defined $outputfile or die "No output file specified"; +} + +my $release = shift; +defined $release or die "No release specified"; + +my $version = shift; +defined $version or die "No version name specified"; + +my $architecture = shift; +defined $architecture or die "No architecture specified"; +$architecture =~ s&^.*[/\\]&&; # Remove directory part if any + +open(FILE, ">$outputfile") or die "Can't create $outputfile: $!"; + +print FILE <<EOF; +/* This file was created by 'make_version' -- don't modify. */ +#define ERLANG_OTP_RELEASE "$release" +#define ERLANG_VERSION "$version" +#define ERLANG_COMPILE_DATE "$time_str" +#define ERLANG_ARCHITECTURE "$architecture" +EOF + +close(FILE); + +exit(0); diff --git a/erts/emulator/utils/mkver.c b/erts/emulator/utils/mkver.c new file mode 100644 index 0000000000..844014e8f5 --- /dev/null +++ b/erts/emulator/utils/mkver.c @@ -0,0 +1,60 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1996-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% + */ +/* + * Makes the file erl_version.h. + */ + +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif +#include <stdio.h> +#include <stdlib.h> +#include <errno.h> +#include <time.h> + +int +main(argc, argv) +int argc; +char** argv; +{ + FILE *file; + time_t now; + char *cnow; + + if (argc != 2) { + fprintf(stderr, "usage: mkver version\n"); + exit(1); + } + + if ((file = fopen("erl_version.h", "wb")) == NULL) { + fprintf(stderr, "Could not create file 'erl_version.h'!\n"); + exit(1); + } + + time(&now); + cnow = ctime(&now); + cnow[24] = '\0'; /* tidelipom */ + fprintf(file, "/* This file was created by mkver -- don't modify.*/\n"); + fprintf(file, "#define ERLANG_VERSION \"%s\"\n", argv[1]); + fprintf(file, "#define ERLANG_COMPILE_DATE \"%s\"\n", cnow); + fclose(file); + + exit(0); + return 0; +} |