#!/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 = 'no'; 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 '-ds') { $dirty_schedulers = shift; die "No -ds argument specified" unless defined $dirty_schedulers; } 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') { if ($dirty_schedulers eq 'yes') { 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"; }