#!/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
#    <-src>/erl_dirty_bif_wrap.c
#    <-src>/erl_guard_bifs.c
#    <-src>/hipe_nbif_impl.c
#    <-include>/hipe_nbif_impl.h
#    <-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 %dirty_bif_tab;

my @bif;
my @bif_info;
my $dirty_schedulers_test = 'no';
my $hipe = 'no';

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;
    } elsif($opt eq '-dst') {
	$dirty_schedulers_test = shift;
	die "No -dst argument specified"
	    unless defined $dirty_schedulers_test;
    } elsif($opt eq '-hipe') {
	$hipe = shift;
	die "No -hipe argument specified"
	    unless defined $hipe;
    } 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);
	my $mfa = "$mod:$name/$arity";
	save_atoms($mod, $name);
	unless (defined $alias) {
	    $alias = "";
	    $alias = "${mod}_" unless $mod eq 'erlang';
	    $alias .= "${name}_$arity";
	}
	my $sched_type;
	my $alias3 = $alias;

	$sched_type = $dirty_bif_tab{$mfa};

	if (!$sched_type or ($type eq 'ubif')) {
	    $sched_type = 'normal';
	}
	elsif ($sched_type eq 'dirty_cpu') {
	    $alias3 = "schedule_dirty_cpu_$alias"
	}
	elsif ($sched_type eq 'dirty_io') {
	    $alias3 = "schedule_dirty_io_$alias"
	}
	else {
	    error("invalid sched_type: $sched_type");
	}

	my $wrapper;
	if ($type eq 'bif') {
	    $wrapper = "wrap_$alias";
	} else {
	    $wrapper = $alias;
	}
	push(@bif, ["am_$atom_alias{$mod}","am_$atom_alias{$name}",$arity,
		    $alias3,$wrapper,$alias]);
	push(@bif_info, [$type, $sched_type, $alias3, $alias]);
    } elsif ($type eq 'dirty-cpu' or $type eq 'dirty-io'
	     or $type eq 'dirty-cpu-test' or $type eq 'dirty-io-test') {
        my($bif,$other) = (@args);
        $bif =~ m@^([a-z_.'0-9]+):(.*)/(\d)$@ or error("invalid BIF");
        my($mod,$name,$arity) = ($1,$2,$3);
        my $mfa = "$mod:$name/$arity";
        if (($type eq 'dirty-cpu')
            or (($dirty_schedulers_test eq 'yes')
                and ($type eq 'dirty-cpu-test'))) {
            $dirty_bif_tab{$mfa} = 'dirty_cpu';
        } elsif (($type eq 'dirty-io')
                 or (($dirty_schedulers_test eq 'yes')
                     and ($type eq 'dirty-io-test'))) {
            $dirty_bif_tab{$mfa} = 'dirty_io';
        }
    } 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],$bif[$i]->[5],$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;
    BifFunction impl;
} BifEntry;

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

typedef struct erts_u_bif {
    BifFunction bif;
    int exp_ix;
} ErtsUBif;

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

#define BIF_SIZE $bif_size

EOF

my $i;
for ($i = 0; $i < @bif; $i++) {
    print "#define BIF_$bif_info[$i]->[3] $i\n";
}

print "\n";

for ($i = 0; $i < @bif; $i++) {
    my $args = join(', ', 'Process*', 'Eterm*', 'UWord*');
    my $name = $bif_info[$i]->[3];
    print "Eterm $name($args);\n";
    print "Eterm wrap_$name($args);\n";
    print "Eterm erts_gc_$name(Process* p, Eterm* reg, Uint live);\n"
	if $bif_info[$i]->[0] eq 'gcbif';
    print "Eterm $bif_info[$i]->[2]($args);\n"
	unless $bif_info[$i]->[1] eq 'normal';
    print "\n";
}

if ($hipe eq 'yes') {
    print "\n#include \"hipe_nbif_impl.h\"\n";
}

print "\n#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_info[$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_guard_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_info[$i]->[0] eq 'gcbif';
    print "  {$bif[$i]->[3], erts_gc_$bif[$i]->[3], BIF_$bif[$i]->[5]},\n";
}
print "  {NULL, NULL, -1}\n";
print "};\n";

print "const ErtsUBif erts_u_bifs[] = {\n";
for ($i = 0; $i < @bif; $i++) {
    next unless $bif_info[$i]->[0] eq 'ubif';
    print "  {$bif[$i]->[3], BIF_$bif[$i]->[5]},\n";
}
print "  {NULL, -1}\n";
print "};\n";

#
# Generate the dirty bif wrappers file.
#

open_file("$src/erl_dirty_bif_wrap.c");
my $i;
includes("erl_process.h", "erl_nfunc_sched.h", "erl_bif_table.h", "erl_atom_table.h");
for ($i = 0; $i < @bif_info; $i++) {
    next if $bif_info[$i]->[1] eq 'normal';
    my $dtype;
    if ($bif_info[$i]->[1] eq 'dirty_cpu') {
	$dtype = "ERTS_SCHED_DIRTY_CPU";
    }
    else {
	$dtype = "ERTS_SCHED_DIRTY_IO";
    }
print <<EOF;
Eterm $bif_info[$i]->[2](Process *c_p, Eterm *regs, BeamInstr *I)
{
    return erts_reschedule_bif(c_p, regs, I, $bif_info[$i]->[3], $dtype);
}

EOF

}

if ($hipe eq 'yes') {

    #
    # Generate the nbif_impl bif wrappers file.
    #

    open_file("$src/hipe_nbif_impl.h");
    print <<EOF;

#ifndef HIPE_NBIF_IMPL_H__
#define HIPE_NBIF_IMPL_H__

EOF

    my $i;
    for ($i = 0; $i < @bif; $i++) {
	print <<EOF;
Eterm nbif_impl_$bif[$i]->[5](Process *c_p, Eterm *regs);
EOF
   }

   print <<EOF;

#endif /* ERL_HIPE_NBIF_IMPL_H__ */

EOF

    #
    # Generate the nbif_impl bif wrappers file.
    #

    open_file("$src/hipe_nbif_impl.c");
    my $i;
    includes("erl_process.h", "erl_nfunc_sched.h", "erl_bif_table.h", "erl_atom_table.h");
    for ($i = 0; $i < @bif; $i++) {

	print <<EOF;
Eterm nbif_impl_$bif[$i]->[5](Process *c_p, Eterm *regs)
{
    return $bif[$i]->[3](c_p, regs, (UWord *) bif_export\[BIF_$bif[$i]->[5]\]);
}

EOF

   }

} # hipe

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