diff options
Diffstat (limited to 'erts/emulator/utils')
| -rwxr-xr-x | erts/emulator/utils/beam_makeops | 178 | ||||
| -rwxr-xr-x | erts/emulator/utils/make_preload | 28 | ||||
| -rwxr-xr-x | erts/emulator/utils/make_tables | 227 |
3 files changed, 313 insertions, 120 deletions
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops index 4407f7e289..05cd48d434 100755 --- a/erts/emulator/utils/beam_makeops +++ b/erts/emulator/utils/beam_makeops @@ -332,9 +332,9 @@ while (<>) { if (/^\%macro:(.*)/) { my($op, $macro, @flags) = split(' ', $1); defined($macro) and $macro =~ /^-/ and - &error("A macro must not start with a hyphen"); + error("A macro must not start with a hyphen"); foreach (@flags) { - /^-/ or &error("Flags for macros should start with a hyphen"); + /^-/ or error("Flags for macros should start with a hyphen"); } error("Macro for '$op' is already defined") if defined $macro{$op}; @@ -347,7 +347,7 @@ while (<>) { # Handle transformations. # if (/=>/) { - &parse_transformation($_); + parse_transformation($_); next; } @@ -357,8 +357,8 @@ while (<>) { $op_num = undef; if (s/^(\d+):\s*//) { $op_num = $1; - $op_num != 0 or &error("Opcode 0 invalid"); - &error("Opcode $op_num already defined") + $op_num != 0 or error("Opcode 0 invalid"); + error("Opcode $op_num already defined") if defined $gen_opname[$op_num]; } @@ -369,11 +369,11 @@ while (<>) { my($obsolete) = $1; my($name) = $2; my($arity) = $3; - $name =~ /^[a-z]/ or &error("Opname must start with a lowercase letter"); + $name =~ /^[a-z]/ or error("Opname must start with a lowercase letter"); defined $gen_arity{$name} and $gen_arity{$name} != $arity and - &error("Opname $name already defined with arity $gen_arity{$name}"); + error("Opname $name already defined with arity $gen_arity{$name}"); defined $unnumbered{$name,$arity} and - &error("Opname $name already defined with arity $gen_arity{$name}"); + error("Opname $name already defined with arity $gen_arity{$name}"); if (defined $op_num) { # Numbered generic operation $gen_opname[$op_num] = $name; @@ -395,16 +395,16 @@ while (<>) { # Name Arg1 Arg2... # my($name, @args) = split; - &error("too many operands") + error("too many operands") if @args > $max_spec_operands; - &syntax_check($name, @args); + syntax_check($name, @args); my $arity = @args; if (defined $gen_opnum{$name,$arity} and $obsolete[$gen_opnum{$name,$arity}]) { error("specific instructions may not be specified for obsolete instructions"); } - push(@{$specific_op{"$name/$arity"}}, [$name, $hot, @args]); + save_specific_ops($name, $arity, $hot, @args); if (defined $op_num) { - &error("specific instructions must not be numbered"); + error("specific instructions must not be numbered"); } elsif (!defined($gen_arity{$name}) && !defined($unnumbered{$name,$arity})) { # # Create an unumbered generic instruction too. @@ -446,7 +446,7 @@ $num_file_opcodes = @gen_opname; # Produce output for the chosen target. # -&$target; +&$target(); # # Produce output needed by the emulator/loader. @@ -462,7 +462,7 @@ sub emulator_output { # $name = "$outdir/beam_opcodes.c"; open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n"; - &comment('C'); + comment('C'); print "#ifdef HAVE_CONFIG_H\n"; print "# include \"config.h\"\n"; print "#endif\n\n"; @@ -475,7 +475,7 @@ sub emulator_output { print '#include "beam_load.h"', "\n"; print "\n"; - print "char tag_to_letter[] = {\n "; + print "const char tag_to_letter[] = {\n "; for ($i = 0; $i < length($genop_types); $i++) { print "'$tag_type[$i]', "; } @@ -489,7 +489,7 @@ sub emulator_output { # Generate code for specific ops. # my($spec_opnum) = 0; - print "OpEntry opc[] = {\n"; + print "const OpEntry opc[] = {\n"; foreach $key (sort keys %specific_op) { $gen_to_spec{$key} = $spec_opnum; $num_specific{$key} = @{$specific_op{$key}}; @@ -525,7 +525,7 @@ sub emulator_output { # Call a generator to calculate size and generate macros # for the emulator. # - my($size, $code, $pack) = &basic_generator($name, $hot, @args); + my($size, $code, $pack) = basic_generator($name, $hot, @args); # # Save the generated $code for later. @@ -566,25 +566,34 @@ sub emulator_output { $sep = ","; } $init .= "}"; - init_item($print_name, $init, $involves_r, $size, $pack, $sign, 0); + init_item($print_name, $init, $involves_r, $size, $pack, $sign); $op_to_name[$spec_opnum] = $instr; $spec_opnum++; } } print "};\n\n"; - print "int num_instructions = $spec_opnum;\n\n"; + print "const int num_instructions = $spec_opnum;\n\n"; + + # + # Print the array for instruction counts. + # + + print "#ifdef ERTS_OPCODE_COUNTER_SUPPORT\n"; + print "Uint erts_instr_count[$spec_opnum];\n"; + print "#endif\n"; + print "\n"; # # Generate transformations. # - &tr_gen(@transformations); + tr_gen(@transformations); # # Print the generic instruction table. # - print "GenOpEntry gen_opc[] = {\n"; + print "const GenOpEntry gen_opc[] = {\n"; for ($i = 0; $i < @gen_opname; $i++) { if ($i == $num_file_opcodes) { print "\n/*\n * Internal generic instructions.\n */\n\n"; @@ -593,7 +602,7 @@ sub emulator_output { my($arity) = $gen_arity[$i]; printf "/* %3d */ ", $i; if (!defined $name) { - &init_item("", 0, 0, 0, -1); + init_item("", 0, 0, 0, -1); } else { my($key) = "$name/$arity"; my($tr) = defined $gen_transform_offset{$key} ? @@ -605,7 +614,7 @@ sub emulator_output { $is_transformed{$name,$arity} or error("instruction $key has no specific instruction"); $spec_op = -1 unless defined $spec_op; - &init_item($name, $arity, $spec_op, $num_specific, $tr); + init_item($name, $arity, $spec_op, $num_specific, $tr); } } print "};\n"; @@ -615,7 +624,7 @@ sub emulator_output { # $name = "$outdir/beam_opcodes.h"; open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n"; - &comment('C'); + comment('C'); print "#ifndef __OPCODES_H__\n"; print "#define __OPCODES_H__\n\n"; @@ -653,14 +662,14 @@ sub emulator_output { my $letter; my $tag_num = 0; - &comment('C', "The following operand types for generic instructions", + comment('C', "The following operand types for generic instructions", "occur in beam files."); foreach $letter (split('', $compiler_types)) { print "#define TAG_$letter $tag_num\n"; $tag_num++; } print "\n"; - &comment('C', "The following operand types are only used in the loader."); + comment('C', "The following operand types are only used in the loader."); foreach $letter (split('', $loader_types)) { print "#define TAG_$letter $tag_num\n"; $tag_num++; @@ -678,8 +687,8 @@ sub emulator_output { print "#define TE_MAX_VARS $te_max_vars\n"; print "\n"; - print "extern char tag_to_letter[];\n"; - print "extern Uint op_transform[];\n"; + print "extern const char tag_to_letter[];\n"; + print "extern const Uint op_transform[];\n"; print "\n"; for ($i = 0; $i < @op_to_name; $i++) { @@ -708,7 +717,7 @@ sub emulator_output { print "#define DEFINE_COUNTING_LABELS"; for ($i = 0; $i < @op_to_name; $i++) { my($name) = $op_to_name[$i]; - print " \\\nCountCase($name): opc[$i].count++; goto lb_$name;"; + print " \\\nCountCase($name): erts_instr_count[$i]++; goto lb_$name;"; } print "\n\n"; @@ -727,26 +736,26 @@ sub emulator_output { $name = "$outdir/beam_tr_funcs.h"; open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n"; - &comment('C'); - &tr_gen_call(@call_table); + comment('C'); + tr_gen_call(@call_table); $name = "$outdir/beam_pred_funcs.h"; open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n"; - &comment('C'); - &tr_gen_call(@pred_table); + comment('C'); + tr_gen_call(@pred_table); # # Implementation of operations for emulator. # $name = "$outdir/beam_hot.h"; open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n"; - &comment('C'); - &print_code(\%hot_code); + comment('C'); + print_code(\%hot_code); $name = "$outdir/beam_cold.h"; open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n"; - &comment('C'); - &print_code(\%cold_code); + comment('C'); + print_code(\%cold_code); } @@ -809,7 +818,7 @@ sub compiler_output { open(STDOUT, ">$outdir/$name") || die "Failed to open $name for writing: $!\n"; print "-module($module).\n"; - &comment('erlang'); + comment('erlang'); print "-export([format_number/0]).\n"; print "-export([opcode/2,opname/1]).\n"; @@ -821,7 +830,7 @@ sub compiler_output { for ($i = 0; $i < @gen_opname; $i++) { next unless defined $gen_opname[$i]; print "%%" if $obsolete[$i]; - print "opcode(", "e($gen_opname[$i]), ", $gen_arity[$i]) -> $i;\n"; + print "opcode(", quote($gen_opname[$i]), ", $gen_arity[$i]) -> $i;\n"; } print "opcode(Name, Arity) -> erlang:error(badarg, [Name,Arity]).\n\n"; @@ -829,7 +838,7 @@ sub compiler_output { for ($i = 0; $i < @gen_opname; $i++) { next unless defined $gen_opname[$i]; print "opname($i) -> {", - "e($gen_opname[$i]), ",$gen_arity[$i]};\n"; + quote($gen_opname[$i]), ",$gen_arity[$i]};\n"; } print "opname(Number) -> erlang:error(badarg, [Number]).\n"; @@ -838,7 +847,7 @@ sub compiler_output { # my($hrl_name) = "$outdir/${module}.hrl"; open(STDOUT, ">$hrl_name") || die "Failed to open $hrl_name for writing: $!\n"; - &comment('erlang'); + comment('erlang'); for ($i = 0; $i < @tag_type && $i < 8; $i++) { print "-define(tag_$tag_type[$i], $i).\n"; @@ -854,11 +863,33 @@ sub syntax_check { my($name, @args) = @_; my($i); - &error("Bad opcode name '$name'") + error("Bad opcode name '$name'") unless $name =~ /^[a-z][\w\d_]*$/; for ($i = 0; $i < @args; $i++) { - &error("Argument " . ($i+1) . ": invalid type '$args[$i]'") - unless defined $arg_size{$args[$i]}; + foreach my $type (split(//, $args[$i])) { + error("Argument " . ($i+1) . ": invalid type '$type'") + unless defined $arg_size{$type}; + } + } +} + +sub save_specific_ops { + my($name,$arity,$hot,@args) = @_; + my(@res) = (""); + + foreach my $arg (@args) { + my @new_res = (); + foreach my $type (split(//, $arg)) { + foreach my $args (@res) { + push @new_res, "$args$type"; + } + } + @res = @new_res; + } + my $key = "$name/$arity"; + foreach my $args (@res) { + @args = split //, $args; + push @{$specific_op{$key}}, [$name,$hot,@args]; } } @@ -919,7 +950,6 @@ sub basic_generator { my($tmp_arg_num) = 1; my($pack_spec) = ''; my($var_decls) = ''; - my($gen_dest_arg) = 'StoreSimpleDest'; my($i); my($no_prefetch) = 0; @@ -955,7 +985,7 @@ sub basic_generator { # if ($flags =~ /-pack/ && $hot) { - ($prefix, $pack_spec, @args) = &do_pack(@args); + ($prefix, $pack_spec, @args) = do_pack(@args); } # @@ -985,11 +1015,11 @@ sub basic_generator { push(@f_types, $_); $prefix .= "GetR($size, $tmp);\n"; last SWITCH; }; - /d/ and do { $var_decls .= "Eterm dst; "; - push(@f, "dst"); + /d/ and do { $var_decls .= "Eterm dst; Eterm* dst_ptr; "; + push(@f, "*dst_ptr"); push(@f_types, $_); $prefix .= "dst = Arg($size);\n"; - $gen_dest_arg = 'StoreResult'; + $prefix .= "dst_ptr = REG_TARGET_PTR(dst);\n"; last SWITCH; }; defined($incl_arg{$_}) @@ -1008,14 +1038,6 @@ sub basic_generator { } # - # If requested, pass a pointer to the destination register. - # The destination must be the last operand. - # - if ($flags =~ /-gen_dest/) { - push(@f, $gen_dest_arg); - } - - # # Add a fail action macro if requested. # @@ -1186,7 +1208,7 @@ sub do_pack { } $down = "$instr[$ap]$down"; - my($unpack) = &make_unpack($tmpnum, $shift[$ap], $mask[$ap]); + my($unpack) = make_unpack($tmpnum, $shift[$ap], $mask[$ap]); $args[$i] = "pack:$this_size:$reg" . "b($unpack)"; if (++$ap == $args_per_word) { @@ -1250,7 +1272,7 @@ sub parse_transformation { foreach (@from) { if (/^(\w+)\((.*?)\)/) { my($name, $arglist) = ($1, $2); - $_ = (&compile_transform_function($name, split(/\s*,\s*/, $arglist))); + $_ = (compile_transform_function($name, split(/\s*,\s*/, $arglist))); } else { (@op) = split; ($rest_var,$_) = compile_transform(1, $rest_var, @op); @@ -1266,7 +1288,7 @@ sub parse_transformation { my @to; if ($to =~ /^(\w+)\((.*?)\)/) { my($name, $arglist) = ($1, $2); - @to = (&compile_transform_function($name, split(/\s*,\s*/, $arglist))); + @to = (compile_transform_function($name, split(/\s*,\s*/, $arglist))); } else { @to = split(/\s*\|\s*/, $to); foreach (@to) { @@ -1288,7 +1310,7 @@ sub compile_transform { my $arity = 0; foreach (@ops) { - my(@list) = &tr_parse_op($src, $_); + my(@list) = tr_parse_op($src, $_); if ($list[1] eq '*') { $rest_var = $list[0]; } elsif (defined $rest_var and $list[0] eq $rest_var) { @@ -1325,7 +1347,7 @@ sub tr_parse_op { if (/^([A-Z]\w*)(.*)/) { $var = $1; $_ = $2; - &error("garbage after variable") + error("garbage after variable") unless /^=(.*)/ or /^(\s*)$/; $_ = $1; } @@ -1336,7 +1358,7 @@ sub tr_parse_op { $type = $1; $_ = $2; foreach (split('', $type)) { - &error("bad type in $op") + error("bad type in $op") unless defined $type_bit{$_} or $type eq '*'; $_ eq 'r' and error("$op: 'r' is not allowed in transformations") @@ -1383,7 +1405,7 @@ sub tr_parse_op { # Nothing more is allowed after the command. - &error("garbage '$_' after operand: $op") + error("garbage '$_' after operand: $op") unless /^\s*$/; # Test that destination has no conditions. @@ -1417,7 +1439,7 @@ sub tr_gen { # Print the generated transformation engine. # my($offset) = 0; - print "Uint op_transform[] = {\n"; + print "const Uint op_transform[] = {\n"; foreach $key (sort keys %gen_transform) { $gen_transform_offset{$key} = $offset; my @instr = @{$gen_transform{$key}}; @@ -1510,7 +1532,7 @@ sub tr_gen_from { # Check that $name/$arity refers to a valid generic instruction. # - &error($where, "invalid generic op $name/$arity") + error($where, "invalid generic op $name/$arity") unless defined $gen_opnum{$name,$arity}; $opnum = $gen_opnum{$name,$arity}; @@ -1538,11 +1560,11 @@ sub tr_gen_from { $type_mask |= $type_bit{$_}; } if ($cond ne 'is_eq') { - push(@code, &make_op($types, 'is_type', $type_mask)); + push(@code, make_op($types, 'is_type', $type_mask)); } else { $cond = ''; - push(@code, &make_op("$types== $val", 'is_type_eq', - $type_mask, $val)); + push(@code, make_op("$types== $val", 'is_type_eq', + $type_mask, $val)); } } } @@ -1551,12 +1573,12 @@ sub tr_gen_from { my($m, $f, $a) = split(/:/, $val); $ignored_var = ''; $may_fail = 1; - push(@code, &make_op('', "$cond", "am_$m", + push(@code, make_op('', "$cond", "am_$m", "am_$f", $a)); } elsif ($cond ne '') { $ignored_var = ''; $may_fail = 1; - push(@code, &make_op('', "$cond", $val)); + push(@code, make_op('', "$cond", $val)); } if ($var ne '') { @@ -1582,7 +1604,7 @@ sub tr_gen_from { $var_type{$var} = 'scalar'; $var{$var} = $var_num; $var_num++; - push(@code, &make_op($var, 'set_var', $var{$var})); + push(@code, make_op($var, 'set_var', $var{$var})); } } if (is_instr($code[$#code], 'set_var')) { @@ -1591,7 +1613,7 @@ sub tr_gen_from { my $var = $ref->[1][1]; push(@code, make_op($comment, 'set_var_next_arg', $var)); } else { - push(@code, &make_op($ignored_var, 'next_arg')); + push(@code, make_op($ignored_var, 'next_arg')); } } @@ -1636,7 +1658,7 @@ sub tr_gen_to { my(@args); foreach $var (@ops) { - &error($where, "variable '$var' unbound") + error($where, "variable '$var' unbound") unless defined $var{$var}; if ($var_type{$var} eq 'scalar') { push(@args, "var[$var{$var}]"); @@ -1659,7 +1681,7 @@ sub tr_gen_to { # my($key) = "$name/$arity"; - &error($where, "invalid generic op $name/$arity") + error($where, "invalid generic op $name/$arity") unless defined $gen_opnum{$name,$arity}; my $opnum = $gen_opnum{$name,$arity}; @@ -1674,15 +1696,15 @@ sub tr_gen_to { if ($type eq '*') { push(@code, make_op($var, 'store_rest_args')); } elsif ($var ne '') { - &error($where, "variable '$var' unbound") + error($where, "variable '$var' unbound") unless defined $var{$var}; my $op = make_op($var, 'store_var_next_arg', $var{$var}); op_slot_usage($op, $var{$var}); push(@code, $op); } elsif ($type ne '') { - push(@code, &make_op('', 'store_type', "TAG_$type")); + push(@code, make_op('', 'store_type', "TAG_$type")); if ($type_val) { - push(@code, &make_op('', 'store_val', $type_val)); + push(@code, make_op('', 'store_val', $type_val)); } push(@code, make_op('', 'next_arg')); } diff --git a/erts/emulator/utils/make_preload b/erts/emulator/utils/make_preload index f489bc2a39..0cd3509b62 100755 --- a/erts/emulator/utils/make_preload +++ b/erts/emulator/utils/make_preload @@ -2,7 +2,7 @@ # # %CopyrightBegin% # -# Copyright Ericsson AB 1999-2016. All Rights Reserved. +# Copyright Ericsson AB 1999-2017. 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. @@ -90,12 +90,12 @@ foreach $file (@ARGV) { open(FILE, $file) or error("failed to read $file: $!"); binmode(FILE); $_ = <FILE>; - $_ = beam_strip($_); + $_ = beam_strip($_, $file); close(FILE); push(@modules, " {\"$module\", " . length($_) . ", preloaded_$module},\n"); - print "unsigned preloaded_size_$module = ", length($_), ";\n"; - print "unsigned char preloaded_$module", "[] = {\n"; + print "const unsigned preloaded_size_$module = ", length($_), ";\n"; + print "const unsigned char preloaded_$module", "[] = {\n"; for ($i = 0; $i < length($_); $i++) { if ($i % 8 == 0 && $comment ne '') { $comment =~ s@/\*@..@g; # Comment start -- avoid warning. @@ -125,10 +125,10 @@ if ($gen_rc) { print @modules; print "END\n"; } elsif ($gen_old) { - print "struct {\n"; + print "const struct {\n"; print " char* name;\n"; print " int size;\n"; - print " unsigned char* code;\n"; + print " const unsigned char* code;\n"; print "} pre_loaded[] = {\n"; foreach (@modules) { print; @@ -147,20 +147,20 @@ sub error { } sub beam_strip { - my($beam) = @_; + my($beam,$file) = @_; my $size_left = length($beam); my %chunk; my %needed_chunk = ('Code' => 1, - 'Atom' => 1, + 'AtU8' => 1, 'ImpT' => 1, 'ExpT' => 1, 'StrT' => 1, 'FunT' => 1, 'LitT' => 1); - die "can't read Beam files for OTP R4 or earlier (sorry)" + die "$file: can't read Beam files for OTP R4 or earlier (sorry)" if $beam =~ /^\x7fBEAM!/; # @@ -177,7 +177,7 @@ sub beam_strip { die "form size $size greater than size ", $size_left, " of module" if $size > $size_left; $size_left -= 4; - die "not a BEAM file: IFF form type is not 'BEAM'" + die "$file: not a BEAM file: IFF form type is not 'BEAM'" unless $beam_id eq 'BEAM'; # @@ -197,6 +197,14 @@ sub beam_strip { } # + # Abort if there is no new-style 'AtU8' atom chunk. + # + + exists $chunk{'AtU8'} or + die "$file: no 'AtU8' chunk (re-compile with " . + "OTP 20 or later)\n"; + + # # Create a new beam file with only the useful chunk types. # diff --git a/erts/emulator/utils/make_tables b/erts/emulator/utils/make_tables index c158778f43..47e1528958 100755 --- a/erts/emulator/utils/make_tables +++ b/erts/emulator/utils/make_tables @@ -36,7 +36,10 @@ use File::Basename; # <-src>/erl_am.c # <-src>/erl_bif_table.c # <-src>/erl_bif_wrap.c -# <-src>/erl_pbifs.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 # @@ -52,10 +55,13 @@ my %atom; my %atom_alias; my %aliases; my $auto_alias_num = 0; +my %dirty_bif_tab; my @bif; -my @implementation; -my @pbif; +my @bif_info; +my $dirty_schedulers = 'no'; +my $dirty_schedulers_test = 'no'; +my $hipe = 'no'; while (@ARGV && $ARGV[0] =~ /^-(\w+)/) { my $opt = shift; @@ -67,6 +73,18 @@ while (@ARGV && $ARGV[0] =~ /^-(\w+)/) { $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"); } @@ -79,23 +97,64 @@ while (<>) { my($type, @args) = split; if ($type eq 'atom') { save_atoms(@args); - } elsif ($type eq 'bif' or $type eq 'ubif') { - my($bif,$alias,$alias2) = (@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; - $wrapper = "wrap_$alias" if $type eq 'bif'; - $wrapper = $alias if $type eq 'ubif'; + if ($type eq 'bif') { + $wrapper = "wrap_$alias"; + } else { + $wrapper = $alias; + } push(@bif, ["am_$atom_alias{$mod}","am_$atom_alias{$name}",$arity, - $alias,$wrapper]); - push(@pbif, $bif =~ m/^'/ && $alias =~ m/^ebif_/); - push(@implementation, $alias2); + $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"); } @@ -144,7 +203,7 @@ 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"; + print "BIF_LIST($bif[$i]->[0],$bif[$i]->[1],$bif[$i]->[2],$bif[$i]->[3],$bif[$i]->[5],$i)\n"; } # @@ -164,10 +223,24 @@ typedef struct bif_entry { 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 @@ -175,17 +248,28 @@ EOF my $i; for ($i = 0; $i < @bif; $i++) { - print "#define BIF_$bif[$i]->[3] $i\n"; + print "#define BIF_$bif_info[$i]->[3] $i\n"; } print "\n"; for ($i = 0; $i < @bif; $i++) { - my $args = join(', ', 'Process*', 'Eterm*'); - print "Eterm $bif[$i]->[3]($args);\n"; - print "Eterm wrap_$bif[$i]->[3]($args, UWord *I);\n"; + 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 "#endif\n"; + +print "\n#endif\n"; # # Generate the bif table file. @@ -216,7 +300,7 @@ includes("export.h", "sys.h", "erl_vm.h", "global.h", "erl_process.h", "bif.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 $func = $bif_info[$i]->[3]; print "Eterm\n"; print "wrap_$func(Process* p, Eterm* args, UWord* I)\n"; print "{\n"; @@ -225,28 +309,107 @@ for ($i = 0; $i < @bif; $i++) { } # -# Generate the package bif file. +# Generate erl_gc_bifs.c. # -open_file("$src/erl_pbifs.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", "erl_atom_table.h"); + "erl_bif_table.h"); +print "const ErtsGcBif erts_gc_bifs[] = {\n"; 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, Eterm* BIF__ARGS)\n"; - print "{\n"; - print " return $orig_func(p, BIF__ARGS);\n"; - print "}\n\n"; + 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) = @_; |