Merge tag 'OTP-21.2' into sverker/map-from-ks-vs-bug

5 files changed, 1727 insertions, 502 deletions

diff --git a/erts/emulator/utils/beam_emu_vars b/erts/emulator/utils/beam_emu_vars
new file mode 100755
index 0000000000..c798a4dada
--- /dev/null
+++ b/erts/emulator/utils/beam_emu_vars
@@ -0,0 +1,122 @@
+#!/usr/bin/perl -w
+use strict;
+
+# Analyse beam_emu.s and try to find out the registers
+# used for the important variables in process_main().
+#
+# Works for .s files from clang or gcc. For gcc, the -fverbose-asm
+# option must be used.
+#
+# Example:
+#
+# $ beam-emu-vars -vars 'c_p E HTOP FCALLS I reg freg' beam_emu.s
+# E: %r13
+# FCALLS: %rcx:98 %rax:88 16(%rsp):50 %rdi:6
+# HTOP: %r10:382 64(%rsp):88 72(%rsp):9 24(%rsp):7 %rcx:6 %r15:6 80(%rsp):3 88(%rsp):2
+# I: %rbx
+# c_p: %rbp
+# freg: 48(%rsp):11 %rcx:8 %rdi:5 %rax:4
+# reg: %r12
+#
+# That means that E, I, c_p, reg seems to be assigned to permanent registers.
+# HTOP seems to be assigned %r10, but it is saved to a scratch location
+# before any function calls. FCALLS and freg seems to be saved in a location on
+# the stack and loaded into a register when used.
+#
+# The exit status will be 0 if all variables are assigned to registers (most of
+# the time), and 1 if one or more variables are assigned to a stack location.
+
+my $vars = 'c_p E FCALLS freg HTOP I reg';
+
+while (@ARGV and $ARGV[0] =~ /^-(.*)/) {
+    $_ = $1;
+    shift;
+    ($vars = shift), next if /^vars/;
+    die "$0: Bad option: -$_\n";
+}
+
+my @vars = split(" ", $vars);
+my %vars;
+@vars{@vars} = @vars;
+
+my $inside;
+my %count;
+
+if (@ARGV != 1) {
+    usage();
+}
+
+while (<>) {
+    if (!$inside && /[.]globl\s*_?process_main/) {
+	$inside = 1;
+    } elsif ($inside && /[.]globl/) {
+	last;
+    }
+    if ($inside) {
+	if (/##DEBUG_VALUE:\s*process_main:([A-Za-z]*)\s*<-\s*(.*)/) {
+	    # clang
+	    my($var,$reg) = ($1,$2);
+	    next if $reg =~ /^[-\d]+$/; # Ignore if number.
+	    $count{$var}->{$reg}++ if $vars{$var};
+	    next;
+	}
+
+	# Parse gcc verbose arguments. Comments are marked with
+	# one '#' (clang marks its comments with two '#').
+	my($src,$dst,$comment) = /movq\s+([^#]+), ([^#]+)#(?!#)\s*(.*)/;
+	next unless $comment;
+	$dst =~ s/\s*$//;
+	my($vsrc,$vdst) = split /,/, $comment, 2;
+	$vdst =~ s/^\s//;
+	update_count(\%count, $vsrc, $src);
+	update_count(\%count, $vdst, $dst);
+	if ($vars{$vdst} and $vsrc eq '%sfp') {
+	    $count{$vdst}->{$src}++;
+	}
+    }
+}
+
+my @first;
+
+OUTER:
+for my $var (sort keys %count) {
+    my $total = 0;
+
+    foreach my $reg (keys %{$count{$var}}) {
+	$total += $count{$var}->{$reg}++;
+    }
+
+    foreach my $reg (keys %{$count{$var}}) {
+	if ($count{$var}->{$reg} > 0.9*$total) {
+	    print "$var: $reg\n";
+	    push @first, $var;
+	    next OUTER;
+	}
+    }
+
+    my @r;
+    foreach my $reg (keys %{$count{$var}}) {
+	push @r, $reg;
+    }
+    @r = sort { $count{$var}->{$b} <=> $count{$var}->{$a} } @r;
+    @r = map { "$_:$count{$var}->{$_}" } @r;
+    push @first, $r[0];
+    print "$var: ", join(' ', @r), "\n";
+}
+
+foreach (@first) {
+    exit 1 if /%rsp/;
+}
+exit 0;
+
+sub update_count {
+    my($count_ref,$var,$reg) = @_;
+    return unless $vars{$var};
+    ${${$count_ref}{$var}}{$reg}++;
+}
+
+sub usage {
+    die qq[usage: beam_emu_vars [ -vars "var1 var2..." ] <filename>.s\n\n] .
+	"The exit status is 0 if all variables are assigned to registers,\n" .
+	"and 1 if one or more variables are allocated to a stack location.\n";
+}
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops
index 4407f7e289..da994fae3e 100755
--- a/erts/emulator/utils/beam_makeops
+++ b/erts/emulator/utils/beam_makeops
@@ -2,7 +2,7 @@
 #
 # %CopyrightBegin%
 #
-# Copyright Ericsson AB 1998-2016. All Rights Reserved.
+# Copyright Ericsson AB 1998-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.
@@ -19,45 +19,40 @@
 # %CopyrightEnd%
 #
 use strict;
-use vars qw($BEAM_FORMAT_NUMBER);
+use vars qw($BEAM_FORMAT_NUMBER $GC_REGEXP);
+use constant COLD => 0;
+use constant WARM => 1;
+use constant HOT => 2;
+
+# Instructions for packing
+use constant PACK_JUMP => 1;
+use constant PACK_IN_INSTR_WORD => 2;
+use constant PACK_OPT_IN_INSTR_WORD => 4;
+
+# Packing commands
+use constant PACK_CMD_TIGHTEST => '1';
+use constant PACK_CMD_TIGHT => '2';
+use constant PACK_CMD_LOOSE => '3';
+use constant PACK_CMD_WIDE => '4';
 
 $BEAM_FORMAT_NUMBER = undef;
+$GC_REGEXP = undef;
 
 my $target = \&emulator_output;
 my $outdir = ".";		# Directory for output files.
 my $verbose = 0;
-my $hot = 1;
+my $hotness = 1;
 my $num_file_opcodes = 0;
 my $wordsize = 32;
-my %defs;			# Defines (from command line).
+my $code_pointers_are_short = 0; # Whether code pointers (to C code) are short.
+my $code_model = 'unknown';
+my %defs;                        # Defines (from command line).
 
 # This is shift counts and mask for the packer.
 my $WHOLE_WORD = '';
-my @pack_instr;
-my @pack_shift;
-my @pack_mask;
 
-$pack_instr[2] = ['6', 'i'];
-$pack_instr[3] = ['0', '0', 'i'];
-$pack_instr[4] = ['6', '6', '6', 'i']; # Only for 64 bit wordsize
-
-$pack_shift[2] = ['0', 'BEAM_LOOSE_SHIFT'];
-$pack_shift[3] = ['0', 'BEAM_TIGHT_SHIFT', '(2*BEAM_TIGHT_SHIFT)'];
-$pack_shift[4] = ['0', 'BEAM_LOOSE_SHIFT', # Only for 64 bit wordsize
-		  '(2*BEAM_LOOSE_SHIFT)',
-		  '(3*BEAM_LOOSE_SHIFT)'];
-
-$pack_mask[2]  = ['BEAM_LOOSE_MASK', $WHOLE_WORD];
-$pack_mask[3]  = ['BEAM_TIGHT_MASK', 'BEAM_TIGHT_MASK', 'BEAM_TIGHT_MASK'];
-$pack_mask[4]  = ['BEAM_LOOSE_MASK', # Only for 64 bit wordsize
-		  'BEAM_LOOSE_MASK',
-		  '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;
+my @basic_pack_options = (0);
+my @extended_pack_options = @basic_pack_options;
 
 # There are two types of instructions: generic and specific.
 # The generic instructions are those generated by the Beam compiler.
@@ -83,6 +78,14 @@ my %num_specific;
 my %gen_to_spec;
 my %specific_op;
 
+# The following hashes are used for error checking.
+my %print_name;
+my %specific_op_arity;
+
+# Information about each specific operator. Key is the print name (e.g. get_list_xxy).
+# Value is a hash.
+my %spec_op_info;
+
 my %gen_arity;
 my @gen_arity;
 
@@ -91,17 +94,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.
 
-my %hot_code;
-my %cold_code;
+# Definitions for instructions combined from micro instructions.
+my %combined_instrs;
+
+my @generated_code;             # Generated code.
+my %sort_order;
 
 my @unnumbered_generic;
 my %unnumbered;
 
 my %is_transformed;
 
+
 #
 # Pre-processor.
 #
@@ -128,7 +136,10 @@ my $loader_types = "nprvlqo";
 my $genop_types = $compiler_types . $loader_types;
 
 #
-# Defines the argument types and their loaded size assuming no packing.
+# Define the operand types and their loaded size assuming no packing.
+#
+# Those are the types that can be used in the definition of a specific
+# instruction.
 #
 my %arg_size = ('r' => 0,	# x(0) - x register zero
 		'x' => 1,	# x(N), N > 0 - x register
@@ -138,23 +149,48 @@ 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
 		'Q' => 1,	# like 'P', but packable
-		'h' => 1,	# character
+		'h' => 1,	# character (not used)
 		'l' => 1,	# float reg
 		'q' => 1,	# literal term
 	     );
 
 #
+# Define the types that may be used in a transformation rule.
+#
+# %pattern_type defines the types that may be used in a pattern
+# on the left side.
+#
+# %construction_type defines the types that may be used when
+# constructing a new instruction on the right side (a subset of
+# the pattern types that are possible to construct).
+#
+my $pattern_types = "acdfjilnopqsuxy";
+my %pattern_type;
+@pattern_type{split("", $pattern_types)} = (1) x length($pattern_types);
+
+my %construction_type;
+foreach my $type (keys %pattern_type) {
+    $construction_type{$type} = 1
+        if index($genop_types, $type) >= 0;
+}
+foreach my $makes_no_sense ('f', 'j', 'o', 'p', 'q') {
+    delete $construction_type{$makes_no_sense};
+}
+
+#
 # Generate bits.
 #
 my %type_bit;
@@ -186,16 +222,17 @@ 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'});
+    # Aliases of 'u'.  Those specify how to load the operand and
+    # what kind of packing can be done.
     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 +259,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");
+    }
 }
 
 #
@@ -235,32 +278,75 @@ while (@ARGV && $ARGV[0] =~ /^-(.*)/) {
     ($target = \&compiler_output), next if /^compiler/;
     ($outdir = shift), next if /^outdir/;
     ($wordsize = shift), next if /^wordsize/;
+    ($code_model = shift), next if /^code-model/;
     ($verbose = 1), next if /^v/;
     ($defs{$1} = $2), next if /^D(\w+)=(\w+)/;
     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;
+    $code_pointers_are_short = $code_model eq 'small';
+}
+
 #
-# Initialize number of arguments per packed word.
+# Initialize pack options.
 #
 
-$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;
+    @basic_pack_options = (0,PACK_JUMP);
+    @extended_pack_options = @basic_pack_options;
+    if ($code_pointers_are_short) {
+        foreach (@basic_pack_options) {
+            push @extended_pack_options, $_ | PACK_IN_INSTR_WORD;
+        }
+    }
+}
+
+#
+# Add placeholders for built-in macros.
+#
+
+my %predef_macros =
+    (OPERAND_POSITION => ['Expr'],
+     IF => ['Expr','IfTrue','IfFalse'],
+     REFRESH_GEN_DEST => [],
+    );
+foreach my $name (keys %predef_macros) {
+    my @args = @{$predef_macros{$name}};
+    my $body = join(':', map { '$' . $_ } @args);
+    $c_code{$name} = [$body,"built-in macro",@args],
+    $c_code_used{$name} = 1;
 }
 
 #
 # 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 +354,7 @@ while (<>) {
     }
     next if /^\s*$/;
     next if /^\#/;
+    next if m@^//@;
 
     #
     # Handle %if.
@@ -310,45 +397,58 @@ while (<>) {
     #
     if (/^([\w_][\w\d_]+)=(.*)/) {
 	no strict 'refs';
-	my($name) = $1;
-	$$name = $2;
+	my $name = $1;
+        my $value = $2;
+        $value =~ s/;\s*$//;
+	$$name = $value;
 	next;
     }
 
     #
-    # Handle %hot/%cold.
+    # Handle %hot, %warm, and %cold.
     # 
     if (/^\%hot/) {
-	$hot = 1;
+	$hotness = HOT;
 	next;
+    } elsif (/^\%warm/) {
+	$hotness = WARM;
+        next;
     } elsif (/^\%cold/) {
-	$hot = 0;
+	$hotness = COLD;
 	next;
     }
-    
+
     #
-    # Handle macro definitions.
+    # Handle transformations.
     #
-    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);
+    if (/=>/) {
+	parse_transformation($_);
 	next;
     }
 
     #
-    # Handle transformations.
+    # Handle C code blocks.
     #
-    if (/=>/) {
-	&parse_transformation($_);
-	next;
+    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;
     }
 
     #
@@ -357,8 +457,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 +469,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;
@@ -394,17 +494,9 @@ while (<>) {
     # Parse specific instructions (only present in emulator/loader):
     #    Name Arg1 Arg2...
     #
-    my($name, @args) = split;
-    &error("too many operands")
-	if @args > $max_spec_operands;
-    &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]);
+    my($name,$arity) = parse_specific_op($_);
     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 +538,19 @@ $num_file_opcodes = @gen_opname;
 # Produce output for the chosen target.
 #
 
-&$target;
+&$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.
@@ -458,11 +562,41 @@ sub emulator_output {
     my $key;			# Loop variable.
 
     #
+    # Generate code and meta information for all instructions.
+    #
+    foreach $key (keys %specific_op) {
+	foreach (@{$specific_op{$key}}) {
+	    my($name, $hotness, @args) = @$_;
+	    my $print_name = print_name($name, @args);
+
+	    my($size, $code, $pack_spec) = cg_basic(name => $name, args => \@args);
+	    if (defined $code) {
+                $code = "OpCase($print_name):\n$code";
+                push @generated_code, [$hotness,$code,($print_name)];
+	    }
+
+            # Note: Some of the information below will be modified
+            # for combined instructions.
+            my %info = ('size' => $size,
+                        'pack_spec' => $pack_spec,
+                        'adj' => 0,
+                        'args' => \@args);
+            $spec_op_info{$print_name} = \%info;
+	}
+    }
+
+    #
+    # Combine micro instruction into instruction blocks and generate
+    # code for them.
+    #
+    combine_micro_instructions();
+
+    #
     # Information about opcodes (beam_opcodes.c).
     #
     $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 +609,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]', ";
     }
@@ -488,8 +622,8 @@ sub emulator_output {
     #
     # Generate code for specific ops.
     #
-    my($spec_opnum) = 0;
-    print "OpEntry opc[] = {\n";
+    my $spec_opnum = 0;
+    print "const OpEntry opc[] = {\n";
     foreach $key (sort keys %specific_op) {
 	$gen_to_spec{$key} = $spec_opnum;
 	$num_specific{$key} = @{$specific_op{$key}};
@@ -503,40 +637,26 @@ sub emulator_output {
 	foreach (@{$specific_op{$key}}) {
 	    my($name, $hot, @args) = @{$_};
 	    my($sign) = join('', @args);
+            $sign =~ s/[?]//g;
 
 	    # The primitive types should sort before other types.
 
-	    my($sort_key) = $sign;
+	    my $sort_key = $sign;
 	    eval "\$sort_key =~ tr/$genop_types/./";
 	    $sort_key .= ":$sign";
-	    $items{$sort_key} = [$name, $hot, $sign, @args];
+            my $print_name = print_name($name, @args);
+	    $items{$sort_key} = $print_name;
 	}
 
 	#
 	# Now call the generator for the sorted result.
 	#
-	foreach (sort keys %items) {
-	    my($name, $hot, $sign, @args) = @{$items{$_}};
+	foreach my $sort_key (sort keys %items) {
+            my $print_name = $items{$sort_key};
+            my $info = $spec_op_info{$print_name};
+            my(@args) = @{$info->{'args'}};
+            @args = map { s/[?]$//; $_ } @args;
 	    my $arity = @args;
-	    my($instr) = "${name}_$sign";
-	    $instr =~ s/_$//;
-
-	    #
-	    # Call a generator to calculate size and generate macros
-	    # for the emulator.
-	    #
-	    my($size, $code, $pack) = &basic_generator($name, $hot, @args);
-
-	    #
-	    # Save the generated $code for later.
-	    #
-	    if (defined $code) {
-		if ($hot) {
-		    push(@{$hot_code{$code}}, $instr);
-		} else {
-		    push(@{$cold_code{$code}}, $instr);
-		}
-	    }
 
 	    #
 	    # Calculate the bit mask which should be used to match this
@@ -558,7 +678,6 @@ sub emulator_output {
 	    }
 
 	    printf "/* %3d */  ", $spec_opnum;
-	    my $print_name = $sign ne '' ? "${name}_$sign" : $name;
 	    my $init = "{";
 	    my $sep = "";
 	    foreach (@bits) {
@@ -566,25 +685,38 @@ sub emulator_output {
 		$sep = ",";
 	    }
 	    $init .= "}";
-	    init_item($print_name, $init, $involves_r, $size, $pack, $sign, 0);
-	    $op_to_name[$spec_opnum] = $instr;
+            my $adj = $info->{'adj'};
+            my $size = $info->{'size'};
+            my $pack_spec = $info->{'pack_spec'};
+            my $sign = join '', @args;
+	    init_item($print_name, $init, $involves_r, $size, $adj, $pack_spec, $sign);
+	    $op_to_name[$spec_opnum] = $print_name;
 	    $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 +725,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 +737,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 +747,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";
 
@@ -637,12 +769,19 @@ 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_LOOSE_MASK 0xFFFFUL\n";
-	print "#define BEAM_TIGHT_MASK 0xFFFFUL\n";
+        if ($code_pointers_are_short) {
+            print "#if !defined(CODE_MODEL_SMALL)\n";
+            print qq[  #error "small code model assumed, but CODE_MODEL_SMALL not defined"\n];
+            print "#endif\n";
+        }
+	print "#define BEAM_WIDE_MASK 0xFFFFFFFFull\n";
+	print "#define BEAM_LOOSE_MASK 0xFFFFull\n";
+	print "#define BEAM_TIGHT_MASK 0xFFFFull\n";
+	print "#define BEAM_TIGHTEST_MASK 0x3FFull\n";
 	print "#define BEAM_WIDE_SHIFT 32\n";
 	print "#define BEAM_LOOSE_SHIFT 16\n";
 	print "#define BEAM_TIGHT_SHIFT 16\n";
+	print "#define BEAM_TIGHTEST_SHIFT 10\n";
     }
     print "\n";
 
@@ -653,14 +792,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 +817,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 +847,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,27 +866,38 @@ 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);
+
+    $name = "$outdir/beam_warm.h";
+    open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
+    comment('C');
+    print_code(WARM);
 
     $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);
+}
 
+sub print_name {
+    my($name,@args) = @_;
+    my $sign = join '', @args;
+    $sign =~ s/[?]//g;
+    $sign ne '' ? "${name}_$sign" : $name;
 }
 
 sub init_item {
@@ -775,29 +925,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).
 #
@@ -809,7 +977,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 +989,7 @@ sub compiler_output {
     for ($i = 0; $i < @gen_opname; $i++) {
 	next unless defined $gen_opname[$i];
 	print "%%" if $obsolete[$i];
-	print "opcode(", &quote($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 +997,7 @@ sub compiler_output {
     for ($i = 0; $i < @gen_opname; $i++) {
 	next unless defined $gen_opname[$i];
 	print "opname($i) -> {",
-	&quote($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 +1006,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";
@@ -848,18 +1016,82 @@ sub compiler_output {
 }
 
 #
-# Check an operation for validity.
+# Parse and store a specific operation.
 #
-sub syntax_check {
-    my($name, @args) = @_;
-    my($i);
+sub parse_specific_op {
+    my($name, @args) = split " ", shift;
+    my $arity = @args;
 
-    &error("Bad opcode name '$name'")
+    # Check for various errors.
+    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]};
+    error("too many operands")
+	if @args > $max_spec_operands;
+    for (my $i = 0; $i < $arity; $i++) {
+        my $arg = $args[$i];
+        $arg =~ s/[?]$//;
+        foreach my $type (split(//, $arg)) {
+            error("Argument " . ($i+1) . ": invalid type '$type'")
+                unless defined $arg_size{$type};
+        }
+    }
+    if (defined $gen_opnum{$name,$arity} and $obsolete[$gen_opnum{$name,$arity}]) {
+	error("specific instructions may not be specified for obsolete instructions");
+    }
+
+    # Expand operands with multiple types to multiple instructions.
+    # (For example, "get_list xy xy xy" will be expanded to six instructions.)
+    my @res = ([]);
+    foreach my $arg (@args) {
+        my @old_res = @res;
+        @res = ();
+        my $marker = ($arg =~ s/[?]$//) ? '?' : '';
+        foreach my $type (split(//, $arg)) {
+            foreach my $args_ref (@old_res) {
+                my @args = @$args_ref;
+                push @args, "$type$marker";
+                push @res, \@args;
+            }
+        }
+    }
+
+    # Store each specific instruction.
+    my $key = "$name/$arity";
+    foreach my $args_ref (@res) {
+        @args = @$args_ref;
+        my $arity = @args;
+        my $loc = "$ARGV($.)";
+        if (defined $specific_op_arity{$name}) {
+            my($prev_arity,$loc) = @{$specific_op_arity{$name}};
+            if ($arity != $prev_arity) {
+                error("$name defined with arity $arity, " .
+                      "but previously defined with arity $prev_arity at $loc");
+            }
+        }
+        $specific_op_arity{$name} = [$arity,$loc];
+        my $print_name = print_name($name, @args);
+        if (defined $print_name{$print_name}) {
+            error("$name @args: already defined at " .
+                  $print_name{$print_name});
+        }
+        $print_name{$print_name} = $loc;
+        push @{$specific_op{$key}}, [$name,$hotness,@args];
+    }
+
+    # Done.
+    ($name,$arity);
+}
+
+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 {
@@ -903,59 +1135,314 @@ 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];
+    }
+
+    # Now generate code for each group.
+    foreach my $group (sort keys %groups) {
+        my($hotness,$code,@labels) =
+            combine_instruction_group($group, @{$groups{$group}});
+        push @generated_code, [$hotness,$code,@labels];
+    }
+}
 
-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($gen_dest_arg) = 'StoreSimpleDest';
-    my($i);
-    my($no_prefetch) = 0;
+sub combine_instruction_group {
+    my($group,@in_instrs) = @_;
+    my $gcode = '';             # Code for the entire group.
+    my $group_hotness = COLD;
 
-    # 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,
-		     );
+    # 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";
+    }
 
-    # Pick up the macro to use and its flags (if any).
+    # Variables.
+    my %offsets;
+    my @instrs;
+    my %num_references;         # Number of references from other sub instructions.
+    my $group_size = 999;
 
-    $macro = $macro{$name} if defined $macro{$name};
-    $flags = $macro_flags{$name} if defined $macro_flags{$name};
+    #
+    # Calculate the number of references from other sub instructions.
+    # This number is useful in several ways:
+    #
+    # * If this number is 0, it is only used as the entry point for a
+    #   function, implying that it does not need a label and that operands
+    #   can be packed into the instruction word.
+    #
+    # * We'll use this number in the sort key, as a tie breaker for sub instructions
+    #   at the same instruction offset.
+    #
+    foreach my $ref_instr (@in_instrs) {
+        my(undef,undef,$first_sub,@other_subs) = @$ref_instr;
+        $num_references{$first_sub} += 0; # Make sure it is defined.
+        foreach my $sub (@other_subs) {
+            $num_references{$sub}++;
+        }
+    }
+
+    # 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, $hotness, @args) = @{$specific_op};
+            $group_hotness = $hotness unless $group_hotness >= $hotness;
+            my $offset = 0;
+            my @rest = @args;
+            my @new_subs;
+            my $print_name = print_name($specific, @args);
+            my $opcase = $print_name;
+            my $last = $subs[$#subs];
+            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 = cg_combined_size(name => $s,
+                                            first => $num_references{$s} == 0,
+                                            args => \@first);
+                $offsets{$s} = $offset
+                    unless defined $offsets{$s} and $offsets{$s} < $offset;
+                $offset += $size - 1;
+                my $label = micro_label($s);
+                push @new_subs, [$opcase,$label,$s,$size-1,@first];
+                $opcase = '';
+            }
+            $spec_op_info{$print_name}->{'size'} = $offset + 1;
+            $group_size = $offset if $group_size >= $offset;
+            push @instrs, [$specific_key,@new_subs];
+        }
+    }
+
+    # 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;
+            my $instr_info = "$opcase:$label:$next:$s:$size:@args";
+            push @all_instrs, [$label,$s,$offsets{$s},$instr_info];
+        }
+    }
+
+    my %order_to_instrs;
+    my %label_to_offset;
+    my %order_to_offset;
+    foreach my $instr (@all_instrs) {
+        my($label,$s,$offset,$instr_info) = @$instr;
+        my $sort_key = sprintf("%02d.%02d", $offset, $num_references{$s});
+        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;
+    my %down;
+    my %up;
+    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;
+            $seen_key .= $opcase;
+
+            if ($opcase ne '') {
+                $gcode .= "OpCase($opcase):\n";
+                push @opcase_labels, $opcase;
+            }
+            if ($num_references{$s}) {
+                $gcode .= "$label:\n";
+            }
+
+            my $flags = '';
+            my $transfer_to_next = '';
+            my $inc = 0;
+
+            unless ($i == $#slots) {
+                $flags = "-no_next";
+                my $next_offset = $label_to_offset{$next};
+                $inc = ($offset + $size) - $next_offset;
+                $transfer_to_next = "I += $inc;\n" if $inc;
+                $transfer_to_next .= "goto $next;\n\n";
+            }
+
+            my($gen_code,$down,$up) =
+                cg_combined_code(name => $s,
+                                 first => $num_references{$s} == 0,
+                                 extra_comments => $flags,
+                                 offset => $offset,
+                                 comp_size => $group_size-$offset,
+                                 inc => $inc,
+                                 args =>\@first);
+            my $spec_label = "$opcase$label";
+            $down{$spec_label} = $down;
+            $up{$spec_label} = $up;
+            $gcode .= $gen_code . $transfer_to_next;
+        }
+        $offset = $order_to_offset{$slots[$i+1]} if $i < $#slots;
+    }
+
+    foreach my $print_name (@opcase_labels) {
+        my $info = $spec_op_info{$print_name};
+        $info->{'adj'} = $info->{'size'} - $group_size - 1;
+    }
 
     #
-    # Add any arguments to be included as macro arguments (for instance,
-    # 'p' is usually not an argument, except for calls).
+    # Assemble pack specifications for all instructions in the group.
     #
+    foreach my $instr (@instrs) {
+        my(undef,@subs) = @{$instr};
+        my $down = '';
+        my $up = '';
+        for (my $i = 0; $i < @subs; $i++) {
+            my($opcase,$label) = @{$subs[$i]};
+            my $spec_label = "$opcase$label";
+            if (defined $down{$spec_label}) {
+                $down = $down{$spec_label} . $down;
+                $up = $up . $up{$spec_label};
+            }
+        }
+        my $print_name = $subs[0]->[0];
+        my $info = $spec_op_info{$print_name};
+        $info->{'pack_spec'} = build_pack_spec("$down:$up");
+    }
+
+    ($group_hotness,"{\n$gcode\n}\n\n",@opcase_labels);
+}
 
-    while ($flags =~ /-arg_(\w)/g) {
-	$incl_arg{$1} = 1;
-    };
+sub micro_label {
+    my $label = shift;
+    $label =~ s/[.]/__/g;
+    $label;
+}
+
+
+#
+# Basic code generation for one instruction.
+#
+
+sub cg_basic {
+    my %params = (@_, pack_options => \@extended_pack_options);
+    my($size,$code,$pack_spec) = code_gen(%params);
+    $pack_spec = build_pack_spec($pack_spec);
+    ($size,$code,$pack_spec);
+}
+
+#
+# Calculate size for a micro instruction.
+#
+
+sub cg_combined_size {
+    my %params = (@_,
+                  pack_options => \@basic_pack_options,
+                  size_only => 1);
+    $params{pack_options} = \@extended_pack_options
+        if $params{first};
+    my($size) = code_gen(%params);
+    $size;
+}
+
+#
+# Generate code for a micro instruction.
+#
+
+sub cg_combined_code {
+    my %params = (@_, pack_options => \@basic_pack_options);
+    $params{pack_options} = \@extended_pack_options
+        if $params{first};
+    my($size,$code,$pack_spec) = code_gen(%params);
+    if ($pack_spec eq '') {
+        ($code,'','');
+    } else {
+        my($down,$up) = split /:/, $pack_spec;
+        ($code,$down,$up);
+    }
+}
+
+sub code_gen {
+    my %params = (extra_comments => '',
+                  offset => 0,
+                  inc => 0,
+                  size_only => 0,
+                  @_);
+    my $name = $params{name};
+    my $extra_comments = $params{extra_comments};
+    my $offset = $params{offset};
+    my $inc = $params{inc};
+    my @args = @{$params{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 (defined $c_code_ref and $name ne 'catch') {
+        my $pack_options = $params{pack_options};
+        ($var_decls, $pack_spec, @args) = do_pack($name, $offset, $pack_options, @args);
     }
 
     #
@@ -963,267 +1450,696 @@ sub basic_generator {
     # the macro.
     #
 
+    my $need_block = 0;
+    my $arg_offset = $offset;
+    my $has_gen_dest = 0;
+    @args = map { s/[?]$//g; $_ } @args;
     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; ";
-			    push(@f, "dst");
-			    push(@f_types, $_);
-			    $prefix .= "dst = Arg($size);\n";
-			    $gen_dest_arg = 'StoreResult';
-			    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;
+                $has_gen_dest = 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");
+                $has_gen_dest = 1;
+                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;
     }
 
     #
-    # If requested, pass a pointer to the destination register.
-    # The destination must be the last operand.
+    # If the implementation is in beam_emu.c or if
+    # the caller only wants the size, we are done.
     #
-    if ($flags =~ /-gen_dest/) {
-	push(@f, $gen_dest_arg);
+    if (not defined $c_code_ref or $params{size_only}) {
+        return ($size+1, undef, '');
     }
 
+    my $group_size = ($params{comp_size} || $size) + $inc;
+
     #
-    # Add a fail action macro 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 =~ /-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 };
-	    }
-	}
-    };
+    if (@f != @c_args) {
+        error("$where: defining '$name' with ", scalar(@c_args),
+              " arguments instead of expected ", scalar(@f), " arguments");
+    }
+
+    for (my $i = 0; $i < @f; $i++) {
+        my $var = $c_args[$i];
+        $bindings{$var} = $f[$i];
+    }
+    $bindings{'NEXT_INSTRUCTION'} = "I+" . ($group_size+$offset+1);
+    $bindings{'IP_ADJUSTMENT'} = $inc;
+    $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";
 
     #
-    # Add a size argument if requested.
+    # 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 next_pf = BeamCodeAddr(I[$instr_offset]);\n";
+        $dispatch_next = "\nI += $instr_offset;\n" .
+            "ASSERT(VALID_INSTR(next_pf));\n" .
+            "GotoPF(next_pf);";
+    }
 
-    $flags =~ /-size/ and do {
-	push(@f, $size);
-    };
+    #
+    # 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",
+                    "}", "");
 
-    # 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);",
-			 "}", "");
-	}
+    # Make sure that $REFRESH_GEN_DEST() is used when a
+    # general destination ('d') may have been clobbered by
+    # a GC.
+    my $gc_error = verify_gc_code($code, $has_gen_dest);
+    if (defined $gc_error) {
+        warn $gc_error;
+        error("... from the body of $name at $where");
+    }
+
+    # Done.
+    ($size+1, $code, $pack_spec);
+}
+
+sub verify_gc_code {
+    my $code = shift;
+    my $has_gen_dest = shift;
+
+    return unless $has_gen_dest;
+
+    if ($code =~ /$GC_REGEXP/o) {
+        my $code_after_gc = substr($code, $+[0]);
+        unless ($code_after_gc =~ /dst_ptr = REG_TARGET_PTR/) {
+            return "pointer to destination register is invalid after GC -- " .
+                "use \$REFRESH_GEN_DEST()\n";
+        }
+    }
+    return undef;
+}
+
+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]);
+
+        my $body;
+        ($body,$code) = expand_macro($macro_name, $after, \%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*//;
+    }
+
+    # Make sure that the number of arguments are correct.
+    if (@vars != @args) {
+        error("calling $name with ", scalar(@args),
+              " arguments instead of expected ", scalar(@vars), " arguments...");
+    }
+
+    # Now combine bindings from the parameter names and arguments.
+    my %bindings = %{$bindings_ref};
+    my %new_bindings;
+
+    # Keep the special, pre-defined bindings.
+    foreach my $key (qw(NEXT_INSTRUCTION IP_ADJUSTMENT)) {
+        $new_bindings{$key} = $bindings{$key};
+    }
+
+    for (my $i = 0; $i < @vars; $i++) {
+        my $arg = $args[$i];
+        $arg = eval { expand_all($arg, \%bindings) };
+        unless (defined $arg) {
+            warn $@;
+            die "... from the body of $name at $where\n";
+        }
+        $new_bindings{$vars[$i]} = $arg;
+    }
+
+    $body = eval { expand_all($body, \%new_bindings) };
+    unless (defined $body) {
+        warn $@;
+        die "... from the body of $name at $where\n";
     }
 
-    # Return the size and code for the macro (if any).
-    $size++;
-    ($size, $code, $pack_spec);
+    # Handle built-in macros.
+    if ($name eq 'OPERAND_POSITION') {
+        if ($body =~ /^I\[(\d+)\]$/) {
+            $body = $1;
+        } else {
+            $body = 0;
+        }
+    } elsif ($name eq 'IF') {
+        my $expr = $new_bindings{Expr};
+        my $bool = eval $expr;
+        if ($@ ne '') {
+            &error("bad expression '$expr' in \$IF()");
+        }
+        my $part = $bool ? 'IfTrue' : 'IfFalse';
+        $body = $new_bindings{$part};
+    } elsif ($name eq 'REFRESH_GEN_DEST') {
+        $body = "dst_ptr = REG_TARGET_PTR(dst)";
+    }
+
+
+    # Wrap body if needed and return result.
+    $body = "do {\n$body\n} while (0)"
+        if needs_do_wrapper($body);
+    ($body,$rest);
+}
+
+# Conservative heuristic to determine whether a do { ... } while(0)
+# wrapper is needed.
+sub needs_do_wrapper {
+    local $_ = shift;
+
+    s@^//[|][^\n]*\n@@;
+    s@^\s*@@s;
+    s@^/[*].*[*]/\s*@@s;
+    return 1 if /^(Eterm|Uint|Sint|int|unsigned)/; # Definitely needed.
+    return 0 if /^do/;
+    return 0 if /^SET_I/;
+    return 0 if /^SET_CP/;
+    return 0 if /^ERTS_NO_FPE_CHECK_INIT/;
+    return 0 if /^ASSERT/;
+    return 0 if /^DTRACE/;
+    return 0 if /^[A-Za-z_]*\s*=/;
+    return 0 if /^c_p->/;
+    return 0 if /^[A-Z_]*SWAPOUT/;
+    return 0 if /^if\s*[(]/;
+    return 0 if /^goto\b/;
+    return 0 if /^\d+/;
+    return 1;                   # Not sure, say that it is needed.
 }
 
 sub do_pack {
-    my(@args) = @_;
+    my($name,$offset,$pack_opts_ref,@args) = @_;
+    my @pack_opts = @$pack_opts_ref;
+    my $opt_arg_pos = -1;
+
+    # Look for an optional use operand not as the first argument.
+    if (@args and $args[0] !~ /[?]$/) {
+        for (my $pos = 0; $pos < @args; $pos++) {
+            if ($args[$pos] =~ /[?]$/) {
+                $opt_arg_pos = $pos;
+                last;
+            }
+        }
+    }
+
+    @args = map { s/[?]$//; $_ } @args; # Remove any optional use marker.
+
+    # If there is an optional operand, extend the array of pack options.
+    if ($opt_arg_pos >= 0) {
+        my @new_pack_opts = grep { $_ & PACK_IN_INSTR_WORD } @pack_opts;
+        @new_pack_opts = map {
+            ($_ & ~ PACK_IN_INSTR_WORD) | PACK_OPT_IN_INSTR_WORD;
+        } @new_pack_opts;
+        push @pack_opts, @new_pack_opts;
+    }
+
+    my $ret = ['', ':', @args];
+    my $score = 0;
+
+    foreach my $options (@pack_opts) {
+        my $this_opt_arg_pos = ($options & PACK_OPT_IN_INSTR_WORD) ? $opt_arg_pos : -1;
+        my($this_score,$this_result) =
+            do_pack_one($name, $options, $this_opt_arg_pos, $offset, @args);
+        if ($this_score > $score) {
+            $ret = $this_result;
+            $score = $this_score;
+        }
+    }
+    return @$ret;
+}
+
+sub do_pack_one {
+    my($name,$options,$opt_arg_pos,$offset,@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.
+    my $pack_in_iw = $options & PACK_IN_INSTR_WORD;
 
     #
-    # Count the number of packable arguments.  If we encounter any 's' or 'd'
-    # arguments, packing is not possible.
+    # 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;
+        if ($options & PACK_JUMP) {
+            $bits_needed{'f'} = 32;
+            $bits_needed{'j'} = 32;
+        }
+    }
+
+    #
+    # 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;
 	}
+        if ($arg =~ /^[fj]$/) {
+            # Only pack the first occurrence of 'f' or 'j'.
+            delete $bits_needed{'f'};
+            delete $bits_needed{'j'};
+        }
     }
 
     #
-    # Get out of here if too few or too many arguments.
+    # Return if there is nothing to pack.
     #
-    return ('', '', @args) if $packable_args < 2;
-
-    my($size) = 0;
-    my($pack_prefix) = '';
-    my($down) = '';		# Pack commands (towards instruction
-				# beginning).
-    my($up) = '';		# Pack commands (storing back while
-				# moving forward).
+    if ($packable_args == 0) {
+        return (-1);
+    } elsif ($packable_args == 1 and $options == 0) {
+        return (-1);
+    }
 
-    my $args_per_word = $args_per_word[$packable_args];
-    my @shift;
-    my @mask;
-    my @instr;
+    #
+    # Determine how many arguments we should pack into each word.
+    #
+    my @args_per_word;
+    my @need_wide_mask;
+    my $bits;
+    my $this_wordsize;
+    my $word = -1;
+
+    my $next_word = sub {
+        $word++;
+        $args_per_word[$word] = 0;
+        $need_wide_mask[$word] = 0;
+        $bits = 0;
+        $this_wordsize = $wordsize;
+    };
 
-    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]};
+    $next_word->();
+    $this_wordsize = 32 if $pack_in_iw;
+    for (my $arg_num = 0; $arg_num < @args; $arg_num++) {
+            my $needed = $bits_needed[$arg_num];
+
+            next unless $needed;
+            next if $arg_num == $opt_arg_pos;
+
+            if ($bits+$needed > $this_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 = $this_wordsize;
+            }
     }
 
     #
+    # Try to balance packing between words.
+    #
+    if (@args_per_word == 1 and $args_per_word[0] == 1 and $pack_in_iw) {
+        # Don't rebalance.
+    } elsif ($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
+				# moving forward).
+    my $arg_num = 0;            # Number of argument.
+
+    # Skip an unpackable argument. Also handle packing of
+    # an single operand into the instruction word.
+    my $skip_unpackable = sub {
+        my($arg) = @_;
+
+        if ($arg_num == $opt_arg_pos) {
+            my $pack = chr(ord('#') + $arg_num);
+            $down = PACK_CMD_WIDE . "$pack$down";
+            my $unpack = "BeamExtraData(I[0])";
+            $args[$arg_num] = "packed:$arg:0:${arg}b($unpack)";
+        } elsif ($arg_size{$arg}) {
+            # Save the argument on the pack engine's stack.
+            my $push = 'g';
+            if ($type_bit{$arg} & $type_bit{'q'}) {
+                # The operand may be a literal.
+                $push = 'q';
+            } elsif ($type_bit{$arg} & $type_bit{'f'}) {
+                # The operand may be a failure label.
+                $push = 'f';
+            }
+            $down = "$push${down}";
+            $up = "${up}p";
+        }
+    };
+
+    #
     # 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.
+    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 $pack_word_size = ($pack_in_iw && $word == 0) ? 32 : $wordsize;
+
+        my($shref,$mref,$iref,$unpack_suffix)  =
+            get_pack_parameters($name, $args_per_word, $pack_word_size,
+                                $need_wide_mask[$word]);
+        my @shift = @$shref;
+        my @mask = @$mref;
+        my @instr = @$iref;
+
+        while ($ap < $args_per_word) {
+            my $reg = $args[$arg_num];
+            my $this_size = $arg_size{$reg};
+
+            if ($bits_needed[$arg_num]) {
+                $this_size = 0;
+
+                if ($ap == 0) {
+                    my $packed_data;
+                    if ($pack_in_iw and $word == 0) {
+                        $packed_data = "BeamExtraData(I[0])";
+                        if ($args_per_word == 1) {
+                            $packed_var = $packed_data;
+                        } else {
+                            $pack_prefix .= "Eterm $packed_var = $packed_data;\n";
+                        }
+                        my $pack = chr(ord('#') + $size);
+                        $down = "$pack$down";
+                    } else {
+                        $packed_data = arg_offset($size + $offset);
+                        $pack_prefix .= "Eterm $packed_var = $packed_data;\n";
+                        $down = "P$down";
+                        $up .= "p";
+                        $this_size = 1;
+                    }
+                }
+
+                $down = "$instr[$ap]$down";
+                my $unpack = make_unpack($packed_var, $shift[$ap], $mask[$ap]);
+                my $macro = "$reg$unpack_suffix";
+                $args[$arg_num] = "packed:$reg:$this_size:$macro($unpack)";
+
+                $ap++;
+            } else {
+                $skip_unpackable->($reg);
+            }
+            $size += $this_size;
+            $arg_num++;
+        }
+    }
+
     #
-    # 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;
-	    }
+    # Skip any unpackable arguments at the end.
+    #
+    while ($arg_num < @args) {
+        my $arg = $args[$arg_num];
+        $skip_unpackable->($arg);
+        $size += $arg_size{$arg};
+        $arg_num++;
+    }
 
-	    $down = "$instr[$ap]$down";
-	    my($unpack) = &make_unpack($tmpnum, $shift[$ap], $mask[$ap]);
-	    $args[$i] = "pack:$this_size:$reg" . "b($unpack)";
+    my $pack_spec = "$down:$up";
+    my $score = pack_score($options, @args);
 
-	    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).
-	    #
+    return ($score, [$pack_prefix,$pack_spec,@args]);
+}
 
-	    $down = "g${down}";
-	    $up = "${up}p";
-	}
-	$size += $this_size;
-    }
+sub get_pack_parameters {
+    my($name,$args_per_word,$pack_word_size,$wide_mask) = @_;
+    my(@shift,@mask,@instr);
+    my $unpack_suffix = 'b';
+
+    if ($wide_mask and $args_per_word > 1) {
+        @shift = ('0', 'BEAM_WIDE_SHIFT');
+        @mask = ('BEAM_WIDE_MASK', $WHOLE_WORD);
+        @instr = (PACK_CMD_WIDE) x 2;
+    } elsif ($args_per_word == 1) {
+        @shift = ('0');
+        @mask = ($WHOLE_WORD);
+        @instr = (PACK_CMD_WIDE);
+    } elsif ($args_per_word == 2) {
+        if ($pack_word_size != $wordsize) {
+            # 64-bit word size, pack 32 bits into instruction word.
+            @shift = ('0', 'BEAM_TIGHT_SHIFT');
+            @mask  = ('BEAM_TIGHT_MASK', $WHOLE_WORD);
+            @instr = (PACK_CMD_TIGHT) x 2;
+        } else {
+            # 32/64 bit word size
+            @shift = ('0', 'BEAM_LOOSE_SHIFT');
+            @mask  = ('BEAM_LOOSE_MASK', $WHOLE_WORD);
+            @instr = (PACK_CMD_LOOSE) x 2;
+        }
+    } elsif ($args_per_word == 3) {
+        if ($pack_word_size != $wordsize) {
+            # 64-bit word size, pack 3 register numbers into instruction word.
+            @shift = ('0', 'BEAM_TIGHTEST_SHIFT', '(2*BEAM_TIGHTEST_SHIFT)');
+            @mask = ('BEAM_TIGHTEST_MASK', 'BEAM_TIGHTEST_MASK', $WHOLE_WORD);
+            @instr = (PACK_CMD_TIGHTEST) x 3;
+            $unpack_suffix = '';
+        } else {
+            # 32/64 bit word size.
+            @shift = ('0', 'BEAM_TIGHT_SHIFT', '(2*BEAM_TIGHT_SHIFT)');
+            if ($wordsize == 32) {
+                @mask = ('BEAM_TIGHT_MASK') x 3;
+            } elsif ($wordsize == 64) {
+                @mask = ('BEAM_TIGHT_MASK', 'BEAM_TIGHT_MASK', $WHOLE_WORD);
+            }
+            @instr = (PACK_CMD_TIGHT) x 3;
+        }
+    } elsif ($args_per_word == 4) {
+        # 64 bit word size only.
+        @shift = ('0',
+                  'BEAM_LOOSE_SHIFT',
+                  '(2*BEAM_LOOSE_SHIFT)',
+		  '(3*BEAM_LOOSE_SHIFT)');
+        @mask = ('BEAM_LOOSE_MASK', 'BEAM_LOOSE_MASK',
+                 'BEAM_LOOSE_MASK', $WHOLE_WORD);
+        @instr = (PACK_CMD_LOOSE) x 4;
+    }
+
+    unless (@shift) {
+        error("$name: internal packing error: args_per_word=$args_per_word, " .
+              "pack_word_size=$pack_word_size");
+    }
+
+    (\@shift,\@mask,\@instr,$unpack_suffix);
+}
+
+sub pack_score {
+    my($options,@args) = @_;
+    my $size = 0;
 
-    my $pack_spec = $down . $up;
-    return ($pack_prefix, $pack_spec, @args);
+    # Calculate the number of words.
+    foreach (@args) {
+        if (/^packed:[^:]*:(\d+)/) {
+            $size += $1;
+        } else {
+            $size += $arg_size{$_}
+        }
+    }
+
+    # Less numbers of words give a higher score; for the same number of
+    # words, using PACK_JUMP or PACK_IN_INSTR_WORD gives a lower score.
+    my $score = 1 + 10*($max_spec_operands - $size);
+    if (($options & PACK_OPT_IN_INSTR_WORD) != 0) {
+        $score += 4;
+    } elsif ($options == PACK_IN_INSTR_WORD) {
+        $score += 0;
+    } elsif ($options == PACK_JUMP) {
+        $score += 1;
+    } elsif ($options == (PACK_JUMP|PACK_IN_INSTR_WORD)) {
+        $score += 2;
+    } elsif ($options == 0) {
+        $score += 3;
+    }
+    $score;
 }
 
 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;
 }
 
+sub build_pack_spec {
+    my $pack_spec = shift;
+    return '' if $pack_spec eq '';
+    my($down,$up) = split /:/, $pack_spec;
+    while ($down =~ /[gfq]$/ and $up =~ /^p/) {
+        $down = substr($down, 0, -1);
+        $up = substr($up, 1);
+    }
+    "$down$up";
+}
+
 sub quote {
     local($_) = @_;
     return "'$_'" if $_ eq 'try';
@@ -1250,7 +2166,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);
@@ -1264,9 +2180,12 @@ sub parse_transformation {
     #
 
     my @to;
-    if ($to =~ /^(\w+)\((.*?)\)/) {
-	my($name, $arglist) = ($1, $2);
-	@to = (&compile_transform_function($name, split(/\s*,\s*/, $arglist)));
+    if ($to =~ /^(\w+)\((.*?)\)(.*)/) {
+	my($name, $arglist, $garbage) = ($1, $2, $3);
+        if ($garbage =~ /\S/) {
+            error("garbage after call to '$name()'");
+        }
+	@to = (compile_transform_function($name, split(/\s*,\s*/, $arglist)));
     } else {
 	@to = split(/\s*\|\s*/, $to);
 	foreach (@to) {
@@ -1288,7 +2207,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 +2244,7 @@ sub tr_parse_op {
     if (/^([A-Z]\w*)(.*)/) {
 	$var = $1;
 	$_ = $2;
-	&error("garbage after variable")
+	error("garbage after variable")
 	    unless /^=(.*)/ or /^(\s*)$/;
 	$_ = $1;
     }
@@ -1335,12 +2254,19 @@ sub tr_parse_op {
     if (/^([a-z*]+)(.*)/) {
 	$type = $1;
 	$_ = $2;
+        error("$type: only a single type is allowed on right side of transformations")
+            if not $src and length($type) > 1;
 	foreach (split('', $type)) {
-	    &error("bad type in $op")
-		unless defined $type_bit{$_} or $type eq '*';
-	    $_ eq 'r' and
-		error("$op: 'r' is not allowed in transformations")
-	}
+            next if $src and $type eq '*';
+            error("$op: not a type")
+                unless defined $type_bit{$_};
+            error("$op: the type '$_' is not allowed in transformations")
+                unless defined $pattern_type{$_};
+            if (not $src) {
+                error("$op: type '$_' is not allowed on the right side of transformations")
+                    unless defined $construction_type{$_};
+            }
+        }
     }
 
     # Get an optional condition. (In source.)
@@ -1373,26 +2299,37 @@ sub tr_parse_op {
     }
 
     # Get an optional value. (In destination.)
-    $type_val = $type eq 'x' ? 1023 : 0;
+    if ($type eq 'x') {
+        $type_val = 1023;
+    } elsif ($type eq 'a') {
+        $type_val = 'am_Empty';
+    } else {
+        $type_val = 0;
+    }
     if (/^=(.*)/) {
-	error("value not allowed in source: $op")
+	error("$op: value not allowed in source")
 	    if $src;
+        error("$op: the type 'n' must not be given a value")
+            if $type eq 'n';
 	$type_val = $1;
 	$_ = '';
     }
 
     # 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.
+    # Check the conditions.
 
-    unless ($src) {
-	error("condition not allowed in destination: $op")
+    if ($src) {
+        error("$op: the type '$type' is not allowed to be compared with a literal value")
+            if $cond and not $construction_type{$type};
+    } else {
+	error("$op: condition not allowed in destination")
 	    if $cond;
-	error("variable name and type cannot be combined in destination: $op")
-	    if $var && $type;
+	error("$op: variable name and type cannot be combined in destination")
+	    if $var and $type;
     }
 
     ($var,$type,$type_val,$cond,$cond_val);
@@ -1417,7 +2354,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 +2447,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 +2475,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 +2488,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 +2519,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 +2528,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 +2573,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 +2596,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 +2611,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_driver_tab b/erts/emulator/utils/make_driver_tab
index ffb5f58ebf..a000b9d415 100755
--- a/erts/emulator/utils/make_driver_tab
+++ b/erts/emulator/utils/make_driver_tab
@@ -2,7 +2,7 @@
 #
 # %CopyrightBegin%
 # 
-# Copyright Ericsson AB 1999-2016. All Rights Reserved.
+# Copyright Ericsson AB 1999-2018. 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.
@@ -30,6 +30,7 @@ use File::Basename;
 my $file = "";
 my $nif = "";
 my @emu_drivers = ();
+my @emu_nifs = ();
 my @static_drivers = ();
 my @static_nifs = ();
 my $mode = 1;
@@ -61,7 +62,7 @@ while (@ARGV) {
     } elsif ($mode == 2) {
         $d = basename $d;
         $d =~ s/_nif(\..*|)$//; # strip nif.* or just nif
-        push(@static_nifs, $d);
+        push(@emu_nifs, $d);
         next;
     }
     $d = basename $d;
@@ -94,37 +95,33 @@ foreach (@static_drivers) {
 }
 
 # The array itself
-print "\nErlDrvEntry *driver_tab[] =\n{\n";
+print "\nErtsStaticDriver driver_tab[] =\n{\n";
 
 foreach (@emu_drivers) {
-    print "    &${_}driver_entry,\n";
+    print "    {&${_}driver_entry, 0},\n";
 }
 
 foreach (@static_drivers) {
-    print "    NULL, /* ${_} */\n";
+    print "    {NULL, 1}, /* ${_} */\n";
 }
-print "    NULL\n};\n";
+print "    {NULL}\n};\n";
 
 print "void erts_init_static_drivers() {\n";
 
 my $index = 0;
 foreach (@static_drivers) {
-    print "    driver_tab[".(scalar @emu_drivers+$index)."] = ${_}_driver_init();\n";
+    print "    driver_tab[".(scalar @emu_drivers+$index)."].de = ${_}_driver_init();\n";
     $index++;
 }
 
 print "}\n";
 
-print <<EOF;
-
-typedef struct ErtsStaticNifEntry_ {
-    const char *nif_name;
-    ErtsStaticNifInitFPtr nif_init;
-} ErtsStaticNifEntry;
-
-EOF
-
 # prototypes
+foreach (@emu_nifs) {
+    my $d = ${_};
+    $d =~ s/\.debug//; # strip .debug
+    print "void *".$d."_nif_init(void);\n";
+}
 foreach (@static_nifs) {
     my $d = ${_};
     $d =~ s/\.debug//; # strip .debug
@@ -134,20 +131,25 @@ foreach (@static_nifs) {
 # The array itself
 print "static ErtsStaticNifEntry static_nif_tab[] =\n{\n";
 
+foreach (@emu_nifs) {
+    my $d = ${_};
+    $d =~ s/\.debug//; # strip .debug
+    print "    {\"${_}\", &".$d."_nif_init, 0},\n";
+}
 foreach (@static_nifs) {
     my $d = ${_};
     $d =~ s/\.debug//; # strip .debug
-    print "{\"${_}\",&".$d."_nif_init},\n";
+    print "    {\"${_}\", &".$d."_nif_init, 1},\n";
 }
 
 print "    {NULL,NULL}\n};\n";
 
 print <<EOF;
-ErtsStaticNifInitFPtr erts_static_nif_get_nif_init(const char *name, int len) {
+ErtsStaticNifEntry* erts_static_nif_get_nif_init(const char *name, int len) {
     ErtsStaticNifEntry* p;
     for (p = static_nif_tab; p->nif_name != NULL; p++)
         if (strncmp(p->nif_name, name, len) == 0 && p->nif_name[len] == 0)
-            return p->nif_init;
+            return p;
     return NULL;
 }
 
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..deee5c2344 100755
--- a/erts/emulator/utils/make_tables
+++ b/erts/emulator/utils/make_tables
@@ -2,7 +2,7 @@
 #
 # %CopyrightBegin%
 #
-# Copyright Ericsson AB 1999-2016. All Rights Reserved.
+# Copyright Ericsson AB 1999-2018. 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.
@@ -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,12 @@ 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_test = 'no';
+my $hipe = 'no';
 
 while (@ARGV && $ARGV[0] =~ /^-(\w+)/) {
     my $opt = shift;
@@ -67,6 +72,14 @@ while (@ARGV && $ARGV[0] =~ /^-(\w+)/) {
 	$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");
     }
@@ -79,23 +92,62 @@ 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') {
+        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 +196,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 +216,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 +241,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";
 }
-print "#endif\n";
+
+if ($hipe eq 'yes') {
+    print "\n#include \"hipe_nbif_impl.h\"\n";
+}
+
+print "\n#endif\n";
 
 #
 # Generate the bif table file.
@@ -216,7 +293,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,27 +302,106 @@ 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) = @_;