diff options
Diffstat (limited to 'erts/emulator/utils/beam_makeops')
| -rwxr-xr-x | erts/emulator/utils/beam_makeops | 989 |
1 files changed, 692 insertions, 297 deletions
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops index 0a30553f71..6c54ab3421 100755 --- a/erts/emulator/utils/beam_makeops +++ b/erts/emulator/utils/beam_makeops @@ -54,11 +54,6 @@ $pack_mask[4] = ['BEAM_LOOSE_MASK', # Only for 64 bit wordsize 'BEAM_LOOSE_MASK', $WHOLE_WORD]; -# Mapping from packagable arguments to number of packed arguments per -# word. Initialized after the wordsize is known. - -my @args_per_word; - # There are two types of instructions: generic and specific. # The generic instructions are those generated by the Beam compiler. # Corresponding to each generic instruction, there is generally a @@ -91,17 +86,22 @@ my @op_to_name; my @obsolete; -my %macro; -my %macro_flags; +# Instructions and micro instructions implemented in C. +my %c_code; # C code block, location, arguments. +my %c_code_used; # Used or not. + +# Definitions for instructions combined from micro instructions. +my %combined_instrs; -my %hot_code; -my %cold_code; +my @generated_code; # Generated code. +my %sort_order; my @unnumbered_generic; my %unnumbered; my %is_transformed; + # # Pre-processor. # @@ -138,13 +138,15 @@ my %arg_size = ('r' => 0, # x(0) - x register zero 'n' => 0, # NIL (implicit) 'c' => 1, # tagged constant (integer, atom, nil) 's' => 1, # tagged source; any of the above + 'S' => 1, # tagged source register (x or y) 'd' => 1, # tagged destination register (r, x, y) 'f' => 1, # failure label 'j' => 1, # either 'f' or 'p' 'e' => 1, # pointer to export entry 'L' => 0, # label - 'I' => 1, # untagged integer - 't' => 1, # untagged integer -- can be packed + 't' => 1, # untagged integer (12 bits) -- can be packed + 'I' => 1, # untagged integer (32 bits) -- can be packed + 'W' => 1, # untagged integer/pointer (one word) 'b' => 1, # pointer to bif 'A' => 1, # arity value 'P' => 1, # byte offset into tuple or stack @@ -186,16 +188,16 @@ sub define_type_bit { define_type_bit('s', $type_bit{'d'} | $type_bit{'i'} | $type_bit{'a'} | $type_bit{'n'} | $type_bit{'q'}); + define_type_bit('S', $type_bit{'d'}); define_type_bit('j', $type_bit{'f'} | $type_bit{'p'}); # Aliases (for matching purposes). - define_type_bit('I', $type_bit{'u'}); define_type_bit('t', $type_bit{'u'}); + define_type_bit('I', $type_bit{'u'}); + define_type_bit('W', $type_bit{'u'}); define_type_bit('A', $type_bit{'u'}); define_type_bit('L', $type_bit{'u'}); define_type_bit('b', $type_bit{'u'}); - define_type_bit('N', $type_bit{'u'}); - define_type_bit('U', $type_bit{'u'}); define_type_bit('e', $type_bit{'u'}); define_type_bit('P', $type_bit{'u'}); define_type_bit('Q', $type_bit{'u'}); @@ -222,6 +224,12 @@ $match_engine_ops{'TOP_fail'} = 1; sanity("tag '$tag': primitive tags must be named with lowercase letters") unless $tag =~ /^[a-z]$/; } + + foreach my $tag (keys %arg_size) { + defined $type_bit{$tag} or + sanity("the tag '$tag' has a size in %arg_size, " . + "but has no defined bit pattern"); + } } # @@ -240,27 +248,46 @@ while (@ARGV && $ARGV[0] =~ /^-(.*)/) { die "$0: Bad option: -$_\n"; } +if ($wordsize == 32) { + $defs{'ARCH_32'} = 1; + $defs{'ARCH_64'} = 0; +} elsif ($wordsize == 64) { + $defs{'ARCH_32'} = 0; + $defs{'ARCH_64'} = 1; +} + # # Initialize number of arguments per packed word. # -$args_per_word[2] = 2; -$args_per_word[3] = 3; -$args_per_word[4] = 2; -$args_per_word[5] = 3; -$args_per_word[6] = 3; - if ($wordsize == 64) { $pack_mask[3] = ['BEAM_TIGHT_MASK', 'BEAM_TIGHT_MASK', $WHOLE_WORD]; - $args_per_word[4] = 4; } # # Parse the input files. # +my $in_c_code = ''; +my $c_code_block; +my $c_code_loc; +my @c_args; + while (<>) { my($op_num); + if ($in_c_code) { + if (/^\}/) { + my $name = $in_c_code; + my $block = $c_code_block; + $in_c_code = ''; + $block =~ s/^ //mg; + chomp $block; + $c_code{$name} = [$block,$c_code_loc,@c_args]; + } else { + $c_code_block .= $_; + } + next; + } chomp; if (s/\\$//) { $_ .= <>; @@ -268,6 +295,7 @@ while (<>) { } next if /^\s*$/; next if /^\#/; + next if m@^//@; # # Handle %if. @@ -325,23 +353,6 @@ while (<>) { $hot = 0; next; } - - # - # Handle macro definitions. - # - if (/^\%macro:(.*)/) { - my($op, $macro, @flags) = split(' ', $1); - defined($macro) and $macro =~ /^-/ and - error("A macro must not start with a hyphen"); - foreach (@flags) { - /^-/ or error("Flags for macros should start with a hyphen"); - } - error("Macro for '$op' is already defined") - if defined $macro{$op}; - $macro{$op} = $macro; - $macro_flags{$op} = join('', @flags); - next; - } # # Handle transformations. @@ -352,6 +363,31 @@ while (<>) { } # + # Handle C code blocks. + # + if (/^(\w[\w.]*)\(([^\)]*)\)\s*{/) { + my $name = $1; + $in_c_code = $name; + $c_code_block = ''; + @c_args = parse_c_args($2); + $c_code_loc = "$ARGV($.)"; + if (defined $c_code{$name}) { + my $where = $c_code{$name}->[1]; + error("$name: already defined at $where"); + } + next; + } + + # + # Handle definition of instructions in terms of + # micro instructions. + # + if (/^(\w+)\s*:=\s*([\w.]+)\s*;\s*$/) { + $combined_instrs{$1} = ["$ARGV($.)",$2]; + next; + } + + # # Parse off the number of the operation. # $op_num = undef; @@ -449,6 +485,18 @@ $num_file_opcodes = @gen_opname; &$target(); # +# Ensure that all C code implementations have been used. +# +{ + my(@unused) = grep(!$c_code_used{$_}, keys %c_code); + foreach my $unused (@unused) { + my(undef,$where) = @{$c_code{$unused}}; + warn "$where: $unused is unused\n"; + } + die "\n" if @unused; +} + +# # Produce output needed by the emulator/loader. # @@ -486,6 +534,11 @@ sub emulator_output { print "\n"; # + # Combine micro instruction into instruction blocks. + # + combine_micro_instructions(); + + # # Generate code for specific ops. # my($spec_opnum) = 0; @@ -525,17 +578,15 @@ 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, 1, '', 0, undef, @args); # # Save the generated $code for later. # if (defined $code) { - if ($hot) { - push(@{$hot_code{$code}}, $instr); - } else { - push(@{$cold_code{$code}}, $instr); - } + $code = "OpCase($instr):\n$code"; + push @generated_code, [$hot,$code,($instr)]; } # @@ -646,7 +697,7 @@ sub emulator_output { print "#if !defined(ARCH_64)\n"; print qq[ #error "64-bit architecture assumed, but ARCH_64 not defined"\n]; print "#endif\n"; - print "#define BEAM_WIDE_MASK 0xFFFFUL\n"; + print "#define BEAM_WIDE_MASK 0xFFFFFFFFUL\n"; print "#define BEAM_LOOSE_MASK 0xFFFFUL\n"; print "#define BEAM_TIGHT_MASK 0xFFFFUL\n"; print "#define BEAM_WIDE_SHIFT 32\n"; @@ -750,13 +801,12 @@ sub emulator_output { $name = "$outdir/beam_hot.h"; open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n"; comment('C'); - print_code(\%hot_code); + print_code(1); $name = "$outdir/beam_cold.h"; open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n"; comment('C'); - print_code(\%cold_code); - + print_code(0); } sub init_item { @@ -784,29 +834,47 @@ sub q { } sub print_code { - my($ref) = @_; - my(%sorted); - my($key, $label); # Loop variables. - - foreach $key (keys %$ref) { - my($sort_key); - my($code) = ''; - foreach $label (@{$ref->{$key}}) { - $code .= "OpCase($label):\n"; - $sort_key = $label; - } - foreach (split("\n", $key)) { - $code .= " $_\n"; - } - $code .= "\n"; - $sorted{$sort_key} = $code; + my($include_hot) = @_; + my %sorted; + + foreach my $ref (@generated_code) { + my($hot,$code,@labels) = @$ref; + next unless $hot == $include_hot; + my($sort_key) = @labels; # Use the first label as sort key. + $sorted{$sort_key} = $code; } foreach (sort keys %sorted) { - print $sorted{$_}; + print_indented_code($sorted{$_}); } } +sub print_indented_code { + my(@code) = @_; + + foreach my $chunk (@code) { + my $indent = 0; + foreach (split "\n", $chunk) { + s/^\s*//; + if (/\}/) { + $indent -= 2; + } + if ($_ eq '') { + print "\n"; + } elsif (/^#/) { + print $_, "\n"; + } else { + print ' ' x $indent, $_, "\n"; + } + if (/\{/) { + $indent += 2; + } + } + print "\n"; + } +} + + # # Produce output needed by the compiler back-end (assembler). # @@ -893,6 +961,18 @@ sub save_specific_ops { } } +sub parse_c_args { + local($_) = @_; + my @res; + + while (s/^(\w[\w\d]*)\s*//) { + push @res, $1; + s/^,\s*// or last; + } + $_ eq '' or error("garbage in argument list: $_"); + @res; +} + sub error { my(@message) = @_; my($where) = $. ? "$ARGV($.): " : ""; @@ -934,58 +1014,206 @@ sub comment { } # -# Basic implementation of instruction in emulator loop -# (assuming no packing). +# Combine micro instruction into instruction blocks. # +sub combine_micro_instructions { + my %groups; + + # Sanity check, normalize micro instructions. + foreach my $instr (keys %combined_instrs) { + my $ref = $combined_instrs{$instr}; + my($def_loc,$def) = @$ref; + my($group,@subs) = split /[.]/, $def; + my $arity = 0; + @subs = map { "$group.$_" } @subs; + foreach my $s (@subs) { + my $code = $c_code{$s}; + defined $code or + error("$def_loc: no definition of $s"); + $c_code_used{$s} = 1; + my(undef,undef,@c_args) = @{$code}; + $arity += scalar(@c_args); + } + push @{$groups{$group}}, [$instr,$arity,@subs]; + } -sub basic_generator { - my($name, $hot, @args) = @_; - my($size) = 0; - my($macro) = ''; - my($flags) = ''; - my(@f); - my(@f_types); - my($fail_type); - my($prefix) = ''; - my($tmp_arg_num) = 1; - my($pack_spec) = ''; - my($var_decls) = ''; - my($i); - my($no_prefetch) = 0; + # Now generate code for each group. + foreach my $group (sort keys %groups) { + my($code,@labels) = combine_instruction_group($group, @{$groups{$group}}); + push @generated_code, [1,$code,@labels]; + } +} - # The following argument types should be included as macro arguments. - my(%incl_arg) = ('c' => 1, - 'i' => 1, - 'a' => 1, - 'A' => 1, - 'N' => 1, - 'U' => 1, - 'I' => 1, - 't' => 1, - 'P' => 1, - 'Q' => 1, - ); +sub combine_instruction_group { + my($group,@in_instrs) = @_; + my $gcode = ''; # Code for the entire group. + + # Get code for the head of the group (if any). + my $head_name = "$group.head"; + $c_code_used{$head_name} = 1; + my $head_code_ref = $c_code{$head_name}; + if (defined $head_code_ref) { + my($head_code,$where,@c_args) = @{$head_code_ref}; + @c_args and error("$where: no arguments allowed for " . + "head function '$head_name()'"); + $gcode = $head_code . "\n"; + } + + # Variables. + my %offsets; + my @instrs; + my %num_references; + my $group_size = 0; + + # Do basic error checking. Associate operands of instructions + # with the correct micro instructions. Calculate offsets for micro + # instructions. + foreach my $ref_instr (@in_instrs) { + my($specific,$arity,@subs) = @$ref_instr; + my $specific_key = "$specific/$arity"; + my $specific_op_ref = $specific_op{$specific_key}; + error("no $specific_key instruction") + unless defined $specific_op_ref; + foreach my $specific_op (@$specific_op_ref) { + my($name, $hot, @args) = @{$specific_op}; + my $offset = 0; + my @rest = @args; + my @new_subs; + my $opcase = $specific; + $opcase .= "_" . join '', @args if @args; + foreach my $s (@subs) { + my $code = $c_code{$s}; + my(undef,undef,@c_args) = @{$code}; + my @first; + foreach (0..$#c_args) { + push @first, shift @rest; + } + my($size,undef) = basic_generator($s, 0, '', 0, undef, @first); + $offsets{$s} = $offset + unless defined $offsets{$s} and $offsets{$s} >= $offset; + $offset += $size - 1; + my $label = micro_label($s); + $num_references{$label} = 0; + push @new_subs, [$opcase,$label,$s,$size-1,@first]; + $opcase = ''; + } + $group_size = $offset if $group_size < $offset; + push @instrs, [$specific_key,@new_subs]; + } + } - # Pick up the macro to use and its flags (if any). + # Link the sub instructions for each instructions to each + # other. + my @all_instrs; + foreach my $instr (@instrs) { + my($specific_key,@subs) = @{$instr}; + for (my $i = 0; $i < @subs; $i++) { + my($opcase,$label,$s,$size,@args) = @{$subs[$i]}; + my $next = ''; + (undef,$next) = @{$subs[$i+1]} if $i < $#subs; + $num_references{$next}++ if $next; + my $instr_info = "$opcase:$label:$next:$s:$size:@args"; + push @all_instrs, [$label,$offsets{$s},$instr_info]; + } + } - $macro = $macro{$name} if defined $macro{$name}; - $flags = $macro_flags{$name} if defined $macro_flags{$name}; + my %order_to_instrs; + my %label_to_offset; + my %order_to_offset; + foreach my $instr (@all_instrs) { + my($label,$offset,$instr_info) = @$instr; + my $sort_key = sprintf("%02d.%02d", $offset, $num_references{$label}); + push @{$order_to_instrs{$sort_key}}, $instr_info; + $label_to_offset{$label} = $offset; + $order_to_offset{$sort_key} = $offset; + } + + my(@slots) = sort {$a <=> $b} keys %order_to_instrs; + + # Now generate the code for the entire group. + my $offset = 0; + my @opcase_labels; + for(my $i = 0; $i < @slots; $i++) { + my $key = $slots[$i]; + + # Sort micro-instructions with OpCase before other micro-instructions. + my(@instrs) = @{$order_to_instrs{$key}}; + my $order_func = sub { + my $a_key = ($a =~ /^:/) ? "1$a" : "0$a"; + my $b_key = ($b =~ /^:/) ? "1$b" : "0$b"; + $a_key cmp $b_key; + }; + @instrs = sort $order_func @instrs; + + my %seen; + foreach my $instr (@instrs) { + my($opcase,$label,$next,$s,$size,$args) = split ":", $instr; + my(@first) = split " ", $args; + + my $seen_key = "$label:$next:" . scalar(@first); + next if $opcase eq '' and $seen{$seen_key}; + $seen{$seen_key} = 1; + + if ($opcase ne '') { + $gcode .= "OpCase($opcase):\n"; + push @opcase_labels, $opcase; + } + if ($num_references{$label}) { + $gcode .= "$label:\n"; + } - # - # Add any arguments to be included as macro arguments (for instance, - # 'p' is usually not an argument, except for calls). - # + my $flags = ''; + my $transfer_to_next = ''; + my $dec = 0; - while ($flags =~ /-arg_(\w)/g) { - $incl_arg{$1} = 1; - }; + unless ($i == $#slots) { + $flags = "-no_next"; + my $next_offset = $label_to_offset{$next}; + $dec = $next_offset - ($offset + $size); + $transfer_to_next = "I -= $dec;\n" if $dec; + $transfer_to_next .= "goto $next;\n\n"; + } + + my(undef,$gen_code) = + basic_generator($s, 0, $flags, $offset, + $group_size-$offset-$dec, @first); + $gcode .= $gen_code . $transfer_to_next; + } + $offset = $order_to_offset{$slots[$i+1]} if $i < $#slots; + } + + ("{\n$gcode\n}\n\n",@opcase_labels); +} + +sub micro_label { + my $label = shift; + $label =~ s/[.]/__/g; + $label; +} + + +# +# Basic implementation of instruction in emulator loop +# (assuming no packing). +# + +sub basic_generator { + my($name,$hot,$extra_comments,$offset,$group_size,@args) = @_; + my $size = 0; + my $flags = ''; + my @f; + my $prefix = ''; + my $tmp_arg_num = 1; + my $pack_spec = ''; + my $var_decls = ''; # - # Pack arguments if requested. + # Pack arguments for hot code with an implementation. # - if ($flags =~ /-pack/ && $hot) { - ($prefix, $pack_spec, @args) = do_pack(@args); + my $c_code_ref = $c_code{$name}; + if ($hot and defined $c_code_ref) { + ($var_decls, $pack_spec, @args) = do_pack(@args); } # @@ -993,244 +1221,411 @@ sub basic_generator { # the macro. # + my $need_block = 0; + my $arg_offset = $offset; foreach (@args) { my($this_size) = $arg_size{$_}; SWITCH: { - /^pack:(\d):(.*)/ and do { push(@f, $2); - push(@f_types, 'packed'); - $this_size = $1; - last SWITCH; - }; - /r/ and do { push(@f, "r(0)"); push(@f_types, $_); last SWITCH }; - /[xy]/ and do { push(@f, "$_" . "b(Arg($size))"); - push(@f_types, $_); - last SWITCH; - }; - /n/ and do { push(@f, "NIL"); push(@f_types, $_); last SWITCH }; - /s/ and do { my($tmp) = "targ$tmp_arg_num"; - $var_decls .= "Eterm $tmp; "; - $tmp_arg_num++; - push(@f, $tmp); - push(@f_types, $_); - $prefix .= "GetR($size, $tmp);\n"; - last SWITCH; }; - /d/ and do { $var_decls .= "Eterm dst; Eterm* dst_ptr; "; - push(@f, "*dst_ptr"); - push(@f_types, $_); - $prefix .= "dst = Arg($size);\n"; - $prefix .= "dst_ptr = REG_TARGET_PTR(dst);\n"; - last SWITCH; - }; - defined($incl_arg{$_}) - and do { push(@f, "Arg($size)"); - push(@f_types, $_); - last SWITCH; - }; - - /[fp]/ and do { $fail_type = $_; last SWITCH }; - - /[eLIFEbASjPowlq]/ and do { last SWITCH; }; + /^packed:d:(\d):(.*)/ and do { + $var_decls .= "Eterm dst = $2;\n" . + "Eterm* dst_ptr = REG_TARGET_PTR(dst);\n"; + push(@f, "*dst_ptr"); + $this_size = $1; + last SWITCH; + }; + /^packed:[a-zA-z]:(\d):(.*)/ and do { + push(@f, $2); + $this_size = $1; + last SWITCH; + }; + /r/ and do { + push(@f, "r(0)"); + last SWITCH; + }; + /[lxyS]/ and do { + push(@f, $_ . "b(" . arg_offset($arg_offset) . ")"); + last SWITCH; + }; + /n/ and do { + push(@f, "NIL"); + last SWITCH; + }; + /s/ and do { + my($tmp) = "targ$tmp_arg_num"; + $var_decls .= "Eterm $tmp;\n"; + $tmp_arg_num++; + push(@f, $tmp); + $prefix .= "GetR($arg_offset, $tmp);\n"; + $need_block = 1; + last SWITCH; + }; + /d/ and do { + $var_decls .= "Eterm dst = " . arg_offset($arg_offset) . ";\n" . + "Eterm* dst_ptr = REG_TARGET_PTR(dst);\n"; + push(@f, "*dst_ptr"); + last SWITCH; + }; + defined $arg_size{$_} and do { + push @f, arg_offset($arg_offset); + last SWITCH; + }; die "$name: The generator can't handle $_, at"; } $size += $this_size; + $arg_offset += $this_size; } # - # Add a fail action macro if requested. + # If the implementation is in beam_emu.c, there is nothing + # more to do. # + unless (defined $c_code_ref) { + return ($size+1, undef, ''); + } - $flags =~ /-fail_action/ and do { - $no_prefetch = 1; - if (!defined $fail_type) { - my($i); - for ($i = 0; $i < @f_types; $i++) { - local($_) = $f_types[$i]; - /[rxycians]/ and do { push(@f, "Badmatch($f[$i])"); next }; - } - } elsif ($fail_type eq 'f') { - push(@f, "ClauseFail()"); - } else { - my($i); - for ($i = 0; $i < @f_types; $i++) { - local($_) = $f_types[$i]; - /[rxycians]/ and do { push(@f, "Badmatch($f[$i])"); next }; - } - } - }; + $group_size = $size unless defined $group_size; # - # Add a size argument if requested. + # Generate main body of the implementation. # + my($c_code,$where,@c_args) = @{$c_code_ref}; + my %bindings; + $c_code_used{$name} = 1; - $flags =~ /-size/ and do { - push(@f, $size); - }; + if (@f != @c_args) { + error("$where: defining '$name' with ", scalar(@c_args), + " arguments instead of expected ", scalar(@f), " arguments"); + } - # Generate the macro if requested. - my($code); - if (defined $macro{$name}) { - my($macro_code) = "$prefix$macro(" . join(', ', @f) . ");"; - $var_decls .= "BeamInstr tmp_packed1;" - if $macro_code =~ /tmp_packed1/; - $var_decls .= "BeamInstr tmp_packed2;" - if $macro_code =~ /tmp_packed2/; - if ($flags =~ /-nonext/) { - $code = join("\n", - "{ $var_decls", - $macro_code, - "}"); - } elsif ($flags =~ /-goto:(\S*)/) { - my $goto = $1; - $code = join("\n", - "{ $var_decls", - $macro_code, - "I += $size + 1;", - "goto $goto;", - "}"); - } elsif ($no_prefetch) { - $code = join("\n", - "{ $var_decls", - $macro_code, - "Next($size);", - "}", ""); - } else { - $code = join("\n", - "{ $var_decls", - "BeamInstr* next;", - "PreFetch($size, next);", - "$macro_code", - "NextPF($size, next);", - "}", ""); - } + for (my $i = 0; $i < @f; $i++) { + my $var = $c_args[$i]; + $bindings{$var} = $f[$i]; + } + $bindings{'NEXT_INSTRUCTION'} = "I+" . ($group_size+$offset+1); + $c_code = eval { expand_all($c_code, \%bindings) }; + unless (defined $c_code) { + warn $@; + error("... from the body of $name at $where"); + } + my(@comments) = $c_code =~ m@//[|]\s*(.*)@g; + $c_code =~ s@//[|]\s*(.*)\n?@@g; + $flags = "@comments $extra_comments"; + + # + # Generate code for transferring to the next instruction. + # + my $dispatch_next; + my $instr_offset = $group_size + $offset + 1; + + if ($flags =~ /-no_next/) { + $dispatch_next = ""; + } elsif ($flags =~ /-no_prefetch/) { + $dispatch_next = "\nI += $instr_offset;\n" . + "ASSERT(VALID_INSTR(*I));\n" . + "Goto(*I);"; + } else { + $var_decls .= "BeamInstr* _nextpf = " . + "(BeamInstr *) I[$instr_offset];\n"; + $dispatch_next = "\nI += $instr_offset;\n" . + "ASSERT(VALID_INSTR(_nextpf));\n" . + "Goto(_nextpf);"; + } + + # + # Assemble the complete code for the instruction. + # + my $body = "$c_code$dispatch_next"; + if ($need_block) { + $body = "$prefix\{\n$body\n}"; + } else { + $body = "$prefix$body"; + } + my $code = join("\n", + "{", + "$var_decls$body", + "}", ""); + ($size+1, $code, $pack_spec); +} + +sub arg_offset { + my $offset = shift; + "I[" . ($offset+1) . "]"; +} + +sub expand_all { + my($code,$bindings_ref) = @_; + my %bindings = %{$bindings_ref}; + + # Expand all $Var occurrences. + $code =~ s/[\$](\w[\w\d]*)(?!\()/defined $bindings{$1} ? $bindings{$1} : "\$$1"/ge; + + # Find calls to macros, $name(...), and expand them. + my $res = ""; + while ($code =~ /[\$](\w[\w\d]*)\(/) { + my $macro_name = $1; + my $keep = substr($code, 0, $-[0]); + my $after = substr($code, $+[0]); + + # Keep the special, pre-defined bindings. + my %new_bindings; + foreach my $key (qw(NEXT_INSTRUCTION)) { + $new_bindings{$key} = $bindings{$key}; + } + + my $body; + ($body,$code) = expand_macro($macro_name, $after, \%new_bindings); + $res .= "$keep$body"; + } + + $res . $code; +} + +sub expand_macro { + my($name,$rest,$bindings_ref) = @_; + + my $c_code = $c_code{$name}; + defined $c_code or + error("calling undefined macro '$name'..."); + $c_code_used{$name} = 1; + my ($body,$where,@vars) = @{$c_code}; + + # Separate the arguments into @args; + my @args; + my $level = 1; + my %inc = ('(' => 1, ')' => -1, + '[' => 1, ']' => -1, + '{' => 1, '}' => -1); + my $arg = undef; + while ($rest =~ /([,\(\[\{\}\]\)]|([^,\(\[\{\}\]\)]*))/g) { + my $token = $1; + my $inc = $inc{$token} || 0; + $level += $inc; + if ($level == 0) { + $rest = substr($rest, pos($rest)); + push @args, $arg if defined $arg; + last; + } + if ($token eq ',') { + if ($level == 1) { + push @args, $arg; + $arg = ""; + } + next; + } + $arg .= $token; + } + + # Trim leading whitespace from each argument. + foreach my $arg (@args) { + $arg =~ s/^\s*//; } - # Return the size and code for the macro (if any). - $size++; - ($size, $code, $pack_spec); + # Now combine bindings from the parameter names and arguments. + my %bindings = %{$bindings_ref}; + if (@vars != @args) { + error("calling $name with ", scalar(@args), + " arguments instead of expected ", scalar(@vars), " arguments..."); + } + for (my $i = 0; $i < @vars; $i++) { + $bindings{$vars[$i]} = $args[$i]; + } + + $body = eval { expand_all($body, \%bindings) }; + unless (defined $body) { + warn $@; + die "... from the body of $name at $where\n"; + } + ("do {\n$body\n} while (0)",$rest); } sub do_pack { my(@args) = @_; my($packable_args) = 0; - my @is_packable; # Packability (boolean) for each argument. - my $wide_packing = 0; - my(@orig_args) = @args; + my @bits_needed; # Bits needed for each argument. + + # + # Define the minimum number of bits needed for the packable argument types. + # + my %bits_needed = ('x' => 10, + 'y' => 10, + 'Q' => 10, + 'l' => 10, + 'S' => 16, + 'd' => 16, + 't' => 16); + if ($wordsize == 64) { + $bits_needed{'I'} = 32; + } # - # Count the number of packable arguments. If we encounter any 's' or 'd' - # arguments, packing is not possible. + # Count the number of packable arguments. # - my $packable_types = "xytQ"; foreach my $arg (@args) { - if ($arg =~ /^[$packable_types]/) { + if (defined $bits_needed{$arg}) { $packable_args++; - push @is_packable, 1; - } elsif ($arg =~ /^I/ and $wordsize == 64 and $packable_args < 2) { - $wide_packing = 1; - push @is_packable, 1; - if (++$packable_args == 2) { - # We can only pack two arguments. Turn off packing - # for the rest of the arguments. - $packable_types = "\xFF"; - } - } elsif ($arg =~ /^[sd]/) { - return ('', '', @args); - } elsif ($arg =~ /^[scq]/ and $packable_args > 0) { - # When packing, this operand will be picked up from the - # code array, put onto the packing stack, and later put - # back into a different location in the code. The problem - # is that if this operand is a literal, the original - # location in the code would have been remembered in a - # literal patch. For packing to work, we would have to - # adjust the position in the literal patch. For the - # moment, adding additional instructions to the packing - # engine to handle this does not seem worth it, so we will - # just turn off packing. - return ('', '', @args); + push @bits_needed, $bits_needed{$arg}; } else { - push @is_packable, 0; + push @bits_needed, 0; } } # - # Get out of here if too few or too many arguments. + # Nothing to pack unless there are at least 2 packable arguments. # return ('', '', @args) if $packable_args < 2; - my($size) = 0; - my($pack_prefix) = ''; - my($down) = ''; # Pack commands (towards instruction + # + # Determine how many arguments we should pack into each word. + # + my @args_per_word; + my @need_wide_mask; + my $bits = 0; + my $word = 0; + $args_per_word[0] = 0; + $need_wide_mask[0] = 0; + for (my $i = 0; $i < @args; $i++) { + if ($bits_needed[$i]) { + my $needed = $bits_needed[$i]; + + my $next_word = sub { + $word++; + $args_per_word[$word] = 0; + $need_wide_mask[$word] = 0; + $bits = 0; + }; + + if ($bits+$needed > $wordsize) { # Does not fit. + $next_word->(); + } + if ($args_per_word[$word] == 4) { # Can't handle more than 4 args. + $next_word->(); + } + if ($needed == 32 and $args_per_word[$word] > 1) { + # Must only pack two arguments in this word, and there + # are already at least two arguments here. + $next_word->(); + } + $args_per_word[$word]++; + $bits += $needed; + if ($needed == 32) { + $need_wide_mask[$word]++; + } + if ($need_wide_mask[$word] and $bits > 32) { + # Can only pack two things in a word where one + # item is 32 bits. Force the next item into + # the next word. + $bits = $wordsize; + } + } + } + + # + # Try to balance packing between words. + # + if ($args_per_word[$#args_per_word] == 1) { + if ($args_per_word[$#args_per_word-1] < 3) { + pop @args_per_word; + } else { + $args_per_word[$#args_per_word-1]--; + $args_per_word[$#args_per_word]++; + } + } elsif (@args_per_word == 2 and + $args_per_word[0] == 4 and + $args_per_word[1] == 2) { + $args_per_word[0] = 3; + $args_per_word[1] = 3; + } elsif (@args_per_word == 2 and + $args_per_word[0] == 3 and + $args_per_word[1] == 1) { + $args_per_word[0] = 2; + $args_per_word[1] = 2; + } + + my $size = 0; + my $pack_prefix = ''; + my $down = ''; # Pack commands (towards instruction # beginning). - my($up) = ''; # Pack commands (storing back while + my $up = ''; # Pack commands (storing back while # moving forward). - - my $args_per_word = $args_per_word[$packable_args]; - my @shift; - my @mask; - my @instr; - - if ($wide_packing) { - @shift = ('0', 'BEAM_WIDE_SHIFT'); - @mask = ('BEAM_WIDE_MASK', $WHOLE_WORD); - @instr = ('w', 'i'); - } else { - @shift = @{$pack_shift[$args_per_word]}; - @mask = @{$pack_mask[$args_per_word]}; - @instr = @{$pack_instr[$args_per_word]}; - } + my $did_some_packing = 0; # Nothing packed yet. + + # Skip an unpackable argument. + my $skip_unpackable = sub { + my($arg) = @_; + + if ($arg_size{$arg} and $did_some_packing) { + # Save the argument on the pack engine's stack. + $down = "g${down}"; + $up = "${up}p"; + } else { + # The argument has either zero size (e.g. r(0)), + # or is to the left of the first packed argument + # and will never be accessed. No need to do + # anything. + } + }; # # Now generate the packing instructions. One complication is that # the packing engine works from right-to-left, but we must generate # the instructions from left-to-right because we must calculate # instruction sizes from left-to-right. - # - # XXX Packing 3 't's in one word won't work. Sorry. - my $did_some_packing = 0; # Nothing packed yet. - my($ap) = 0; # Argument number within word. - my($tmpnum) = 1; # Number of temporary variable. - my($expr) = ''; - for (my $i = 0; $i < @args; $i++) { - my($reg) = $args[$i]; - my($this_size) = $arg_size{$reg}; - if ($is_packable[$i]) { - $this_size = 0; - $did_some_packing = 1; - - if ($ap == 0) { - $pack_prefix .= "tmp_packed$tmpnum = Arg($size);\n"; - $up .= "p"; - $down = "P$down"; - $this_size = 1; - } - - $down = "$instr[$ap]$down"; - my($unpack) = make_unpack($tmpnum, $shift[$ap], $mask[$ap]); - $args[$i] = "pack:$this_size:$reg" . "b($unpack)"; + my $arg_num = 0; + for (my $word = 0; $word < @args_per_word; $word++) { + my $ap = 0; # Argument number within word. + my $packed_var = "tmp_packed" . ($word+1); + my $args_per_word = $args_per_word[$word]; + my @shift; + my @mask; + my @instr; + + if ($need_wide_mask[$word]) { + @shift = ('0', 'BEAM_WIDE_SHIFT'); + @mask = ('BEAM_WIDE_MASK', $WHOLE_WORD); + @instr = ('w', 'i'); + } else { + @shift = @{$pack_shift[$args_per_word]}; + @mask = @{$pack_mask[$args_per_word]}; + @instr = @{$pack_instr[$args_per_word]}; + } - if (++$ap == $args_per_word) { - $ap = 0; - $tmpnum++; - } - } elsif ($arg_size{$reg} && $did_some_packing) { - # - # This is an argument that can't be packed. Normally, we must - # save it on the pack engine's stack, unless: - # - # 1. The argument has zero size (e.g. r(0)). Such arguments - # will not be loaded. They disappear. - # 2. If the argument is on the left of the first packed argument, - # the packing engine will never access it (because the engine - # operates from right-to-left). - # + while ($ap < $args_per_word) { + my $reg = $args[$arg_num]; + my $this_size = $arg_size{$reg}; + if ($bits_needed[$arg_num]) { + $this_size = 0; + $did_some_packing = 1; + + if ($ap == 0) { + $pack_prefix .= "Eterm $packed_var = " . + arg_offset($size) . ";\n"; + $up .= "p"; + $down = "P$down"; + $this_size = 1; + } + + $down = "$instr[$ap]$down"; + my $unpack = make_unpack($packed_var, $shift[$ap], $mask[$ap]); + $args[$arg_num] = "packed:$reg:$this_size:$reg" . "b($unpack)"; + + $ap++; + } else { + $skip_unpackable->($reg); + } + $size += $this_size; + $arg_num++; + } + } - $down = "g${down}"; - $up = "${up}p"; - } - $size += $this_size; + # + # Skip any unpackable arguments at the end. + # + while ($arg_num < @args) { + $skip_unpackable->($args[$arg_num]); + $arg_num++; } my $pack_spec = $down . $up; @@ -1238,9 +1633,9 @@ sub do_pack { } sub make_unpack { - my($tmpnum, $shift, $mask) = @_; + my($packed_var, $shift, $mask) = @_; - my($e) = "tmp_packed$tmpnum"; + my $e = $packed_var; $e = "($e>>$shift)" if $shift; $e .= "&$mask" unless $mask eq $WHOLE_WORD; $e; |