diff options
Diffstat (limited to 'erts/emulator/utils/make_tables')
| -rwxr-xr-x | erts/emulator/utils/make_tables | 368 |
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"; +} |