From fe32a91def97823b036ccad946b84853688b41af Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Bj=C3=B6rn=20Gustavsson?= <bjorn@erlang.org>
Date: Mon, 13 Jun 2011 17:43:59 +0200
Subject: Get rid of redundant 'try_me_else' and 'fail' instructions

If the left part of a transformation will always match, omit the
the 'try_me_else' and 'fail' instructions.

As part of this optimization, make it an error to have a
transformation that can never be reached because of a previous
transformation that will always match. (Remove one transformation
from ops.tab that was found to be unreachable.)
---
 erts/emulator/utils/beam_makeops | 43 ++++++++++++++++++++++++++++++++++------
 1 file changed, 37 insertions(+), 6 deletions(-)

(limited to 'erts/emulator/utils')

diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops
index ec3d6c067d..7b66496856 100755
--- a/erts/emulator/utils/beam_makeops
+++ b/erts/emulator/utils/beam_makeops
@@ -1395,18 +1395,24 @@ sub tr_gen_from {
     my($op, $ref);		# Loop variables.
     my $where = "left side of transformation in line $line: ";
     my %var_used = %$used_ref;
+    my $may_fail = 0;
+    my $is_first = 1;
 
     foreach $ref (@tr) {
 	my($name, $arity, @ops) = @$ref;
 	my($key) = "$name/$arity";
 	my($opnum);
 
+	$may_fail = 1 unless $is_first;
+	$is_first = 0;
+
 	#
 	# A name starting with a period is a C pred function to be called.
 	#
 
 	if ($name =~ /^\.(\w+)/) {
 	    $name = $1;
+	    $may_fail = 1;
 	    my $var;
 	    my(@args);
 
@@ -1432,6 +1438,8 @@ sub tr_gen_from {
 	    my $ignored_var = "$var (ignored)";
 
 	    if ($type ne '' && $type ne '*') {
+		$may_fail = 1;
+
 		#
 		# The is_bif, is_not_bif, and is_func instructions have
 		# their own built-in type test and don't need to
@@ -1460,16 +1468,19 @@ sub tr_gen_from {
 	    if ($cond eq 'is_func') {
 		my($m, $f, $a) = split(/:/, $val);
 		$ignored_var = '';
+		$may_fail = 1;
 		push(@code, &make_op('', "$cond", "am_$m",
 				     "am_$f", $a));
 	    } elsif ($cond ne '') {
 		$ignored_var = '';
+		$may_fail = 1;
 		push(@code, &make_op('', "$cond", $val));
 	    }
 
 	    if ($var ne '') {
 		if (defined $var{$var}) {
 		    $ignored_var = '';
+		    $may_fail = 1;
 		    push(@code, &make_op($var, 'is_same_var', $var{$var}));
 		} elsif ($type eq '*') {
 		    #
@@ -1504,7 +1515,8 @@ sub tr_gen_from {
     # Insert the commit operation.
     #
     pop(@code);		# Get rid of 'next_instr'
-    push(@code, &make_op('', 'commit'));
+
+    push(@code, make_op($may_fail ? '' : 'always reached', 'commit'));
 
     #
     # If there is an rest_args instruction, we must insert its correct
@@ -1553,6 +1565,10 @@ sub tr_gen_to {
     my($op, $ref);		# Loop variables.
     my($where) = "right side of transformation in line $line: ";
 
+    my $last_instr = $code[$#code];
+    my $cannot_fail = is_instr($last_instr, 'commit') &&
+	(get_comment($last_instr) =~ /^always/);
+
     foreach $ref (@tr) {
 	my($name, $arity, @ops) = @$ref;
 
@@ -1625,12 +1641,20 @@ sub tr_gen_to {
     $min_window{$key} = $min_window
 	if $min_window{$key} > $min_window;
 
-    pop(@{$gen_transform{$key}})
+    my $prev_last;
+    $prev_last = pop(@{$gen_transform{$key}})
 	if defined @{$gen_transform{$key}}; # Fail
-    my(@prefix) = (&make_op($comment), &make_op('', 'try_me_else', &tr_code_len(@code)));
-    unshift(@code, @prefix);
-    push(@{$gen_transform{$key}},
-	 @code,	 make_op(""), make_op("$key", 'fail'));
+
+    if ($prev_last && !is_instr($prev_last, 'fail')) {
+	error("Line $line: A previous transformation shadows '$orig_transform'");
+    }
+    unless ($cannot_fail) {
+	unshift(@code, make_op('', 'try_me_else',
+			       tr_code_len(@code)));
+	push(@code, make_op(""), make_op("$key", 'fail'));
+    }
+    unshift(@code, make_op($comment));
+    push(@{$gen_transform{$key}}, @code),
 }
 
 sub tr_code_len {
@@ -1654,6 +1678,13 @@ sub is_instr {
     $ref->[1][0] eq $op;
 }
 
+sub get_comment {
+    my($ref,$op) = @_;
+    return '' unless ref($ref) eq 'ARRAY';
+    $ref->[2];
+}
+
+
 sub tr_gen_call {
     my(@call_table) = @_;
     my($i);
-- 
cgit v1.2.3