The R13B03 release.OTP_R13B03

1 files changed, 368 insertions, 0 deletions

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";
+}