#!/usr/bin/env perl 
#
# %CopyrightBegin%
#
# Copyright Ericsson AB 1999-2016. All Rights Reserved.
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions 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
#    <-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 @bif_type;

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' or $type eq 'gcbif') {
	if (@args > 2) {
	    error("$type only allows two arguments");
	}
	my($bif,$alias) = (@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(@bif_type, $type);
    } 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;

typedef struct erts_gc_bif {
    BifFunction bif;
    BifFunction gc_bif;
} ErtsGcBif;

extern BifEntry bif_table[];
extern Export* bif_export[];
extern const ErtsGcBif erts_gc_bifs[];

#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 $args = join(', ', 'Process*', 'Eterm*');
    my $name = $bif[$i]->[3];
    print "Eterm $name($args);\n";
    print "Eterm wrap_$name($args, UWord *I);\n";
    print "Eterm erts_gc_$name(Process* p, Eterm* reg, Uint live);\n"
	if $bif_type[$i] eq 'gcbif';
    print "\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 "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];
    print "Eterm\n";
    print "wrap_$func(Process* p, Eterm* args, UWord* I)\n";
    print "{\n";
    print "    return erts_bif_trace($i, p, args, I);\n";
    print "}\n\n";
}

#
# Generate erl_gc_bifs.c.
#

open_file("$src/erl_gc_bifs.c");
my $i;
includes("export.h", "sys.h", "erl_vm.h", "global.h", "erl_process.h", "bif.h",
	 "erl_bif_table.h");
print "const ErtsGcBif erts_gc_bifs[] = {\n";
for ($i = 0; $i < @bif; $i++) {
    next unless $bif_type[$i] eq 'gcbif';
    my $arity = $bif[$i]->[2];
    my $func = $bif[$i]->[3];
    print "  {$func, erts_gc_$func},\n";
}
print "  {0, 0}\n";
print "};\n";

#
# Utilities follow.
#

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