File 1025-Generate-C-code-for-the-transformation-eng... of Package erlang

Overview Repositories Revisions Requests Users Attributes Meta

File 1025-Generate-C-code-for-the-transformation-engine.patch of Package erlang

From 4dbc9988e7f764d05d31e8432e80ad0d88c8a41a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Bj=C3=B6rn=20Gustavsson?= <bjorn@erlang.org>
Date: Sat, 13 May 2023 07:14:35 +0200
Subject: [PATCH 5/5] Generate C code for the transformation engine

Generating C code for the transformation engine is overall simpler
than using a bespoke virtual machine and it makes code loading
somewhat faster.
---
 erts/emulator/Makefile.in                  |   3 -
 erts/emulator/beam/beam_load.c             |   2 +-
 erts/emulator/beam/beam_transform_engine.c | 371 ---------------
 erts/emulator/internal_doc/beam_makeops.md |   8 +-
 erts/emulator/utils/beam_makeops           | 502 +++++++++++++++------
 5 files changed, 379 insertions(+), 507 deletions(-)
 delete mode 100644 erts/emulator/beam/beam_transform_engine.c

diff --git a/erts/emulator/Makefile.in b/erts/emulator/Makefile.in
index 5451bdf804..80ebf2a070 100644
--- a/erts/emulator/Makefile.in
+++ b/erts/emulator/Makefile.in
@@ -584,7 +584,6 @@ $(TTF_DIR)/beam_warm.h \
 $(TTF_DIR)/beam_hot.h \
 $(TTF_DIR)/beam_opcodes.c \
 $(TTF_DIR)/beam_opcodes.h \
-$(TTF_DIR)/beam_transform.c \
 	: $(TTF_DIR)/OPCODES-GENERATED
 $(TTF_DIR)/OPCODES-GENERATED: $(OPCODE_TABLES) utils/beam_makeops
 	$(gen_verbose)LANG=C $(PERL) utils/beam_makeops \
@@ -1013,8 +1012,6 @@ COMMON_OBJS = \
     $(OBJDIR)/beam_load.o \
     $(OBJDIR)/beam_opcodes.o \
     $(OBJDIR)/beam_ranges.o \
-    $(OBJDIR)/beam_transform.o \
-    $(OBJDIR)/beam_transform_engine.o \
     $(OBJDIR)/beam_transform_helpers.o \
     $(OBJDIR)/code_ix.o
 
diff --git a/erts/emulator/beam/beam_load.c b/erts/emulator/beam/beam_load.c
index d051085023..839d50d50b 100644
--- a/erts/emulator/beam/beam_load.c
+++ b/erts/emulator/beam/beam_load.c
@@ -417,7 +417,7 @@ static int load_code(LoaderState* stp)
 
     do_transform:
         ASSERT(stp->genop != NULL);
-        if (gen_opc[stp->genop->op].transform != -1) {
+        if (gen_opc[stp->genop->op].transform) {
             if (stp->genop->next == NULL) {
                 /*
                  * Simple heuristic: Most transformations requires
diff --git a/erts/emulator/beam/beam_transform_engine.c b/erts/emulator/beam/beam_transform_engine.c
deleted file mode 100644
index 7891c901df..0000000000
--- a/erts/emulator/beam/beam_transform_engine.c
+++ /dev/null
@@ -1,371 +0,0 @@
-/*
- * %CopyrightBegin%
- *
- * Copyright Ericsson AB 2020-2022. All Rights Reserved.
- *
- * Licensed under the Apache License, Version 2.0 (the "License");
- * you may not use this file except in compliance with the License.
- * You may obtain a copy of the License at
- *
- *     http://www.apache.org/licenses/LICENSE-2.0
- *
- * Unless required by applicable law or agreed to in writing, software
- * distributed under the License is distributed on an "AS IS" BASIS,
- * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
- * See the License for the specific language governing permissions and
- * limitations under the License.
- *
- * %CopyrightEnd%
- */
-
-#ifdef HAVE_CONFIG_H
-#  include "config.h"
-#endif
-
-#include "sys.h"
-#include "erl_vm.h"
-#include "export.h"
-#include "bif.h"
-#include "beam_load.h"
-
-int
-erts_transform_engine(LoaderState* st)
-{
-    Uint op;
-    int ap;			/* Current argument. */
-    const Uint* restart; /* Where to restart if current match fails. */
-    BeamOpArg var[TE_MAX_VARS];	/* Buffer for variables. */
-    BeamOpArg* rest_args = NULL;
-    int num_rest_args = 0;
-    int i;			/* General index. */
-    Uint mask;
-    BeamOp* instr;
-    BeamOp* first = st->genop;
-    BeamOp* keep = NULL;
-    const Uint* pc;
-    static Uint restart_fail[1] = {TOP_fail};
-
-    ASSERT(gen_opc[first->op].transform != -1);
-    restart = op_transform + gen_opc[first->op].transform;
-
- restart:
-    ASSERT(restart != NULL);
-    pc = restart;
-    ASSERT(*pc < NUM_TOPS);	/* Valid instruction? */
-    instr = first;
-
-#ifdef DEBUG
-    restart = NULL;
-#endif
-    ap = 0;
-    for (;;) {
-	op = *pc++;
-
-	switch (op) {
-	case TOP_next_instr:
-	    instr = instr->next;
-	    ap = 0;
-	    if (instr == NULL) {
-		/*
-		 * We'll need at least one more instruction to decide whether
-		 * this combination matches or not.
-		 */
-		return TE_SHORT_WINDOW;
-	    }
-	    if (*pc++ != instr->op)
-		goto restart;
-	    break;
-	case TOP_is_type:
-	    mask = *pc++;
-
-	    ASSERT(ap < instr->arity);
-	    ASSERT(instr->a[ap].type < BEAM_NUM_TAGS);
-	    if (((1 << instr->a[ap].type) & mask) == 0)
-		goto restart;
-	    break;
-	case TOP_pred:
-	    i = *pc++;
-            i = erts_beam_eval_predicate((unsigned) i, st, var, rest_args);
-	    if (i == 0)
-		goto restart;
-	    break;
-	case TOP_is_eq:
-	    ASSERT(ap < instr->arity);
-	    if (*pc++ != instr->a[ap].val)
-		goto restart;
-	    break;
-#if defined(TOP_is_bif)
-	case TOP_is_bif:
-	    {
-		int bif_number = *pc++;
-
-		/*
-		 * In debug build, the type must be 'u'.
-		 * In a real build, don't match.  (I.e. retain the original
-		 * call instruction, this will work, but it will be a
-		 * slight performance loss.)
-		 */
-
-		ASSERT(instr->a[ap].type == TAG_u);
-		if (instr->a[ap].type != TAG_u)
-		    goto restart;
-
-		/*
-		 * In debug build, the assertion will catch invalid indexes
-		 * immediately.  In a real build, the loader will issue
-		 * an diagnostic later when the instruction is loaded.
-		 */
-
-		i = instr->a[ap].val;
-		ASSERT(i < st->beam.imports.count);
-                if (i >= st->beam.imports.count) {
-                    goto restart;
-                } else {
-                    BifEntry *entry = st->bif_imports[i];
-
-                    if (!entry) {
-                        /* Not a BIF */
-                        goto restart;
-                    }
-
-                    if (bif_number >= 0 && entry != &bif_table[bif_number]) {
-                        /* Specific BIF not a match. */
-                        goto restart;
-                    }
-                }
-	    }
-	    break;
-#endif
-#if defined(TOP_is_not_bif)
-	case TOP_is_not_bif:
-	    {
-		pc++;
-		i = instr->a[ap].val;
-
-		/*
-		 * In debug build, the type must be 'u'.
-		 */
-		ASSERT(instr->a[ap].type == TAG_u);
-		if (instr->a[ap].type != TAG_u) {
-		    goto restart;
-		} else if (i < st->beam.imports.count) {
-                    BeamFile_ImportEntry *import;
-
-                    if (st->bif_imports[i]) {
-                        goto restart;
-                    }
-
-                    /* erlang:apply/2,3 are strange. They exist as (dummy) BIFs
-                     * so that they are included in the export table before
-                     * the erlang module is loaded. They also exist in the
-                     * erlang module as functions. When used in code, a special
-                     * Beam instruction is used.
-                     *
-                     * Below we recognize erlang:apply/2,3 as special. This is
-                     * necessary because after setting a trace pattern on
-                     * them, you can no longer see from the export entry that
-                     * they are special. */
-                    import = &st->beam.imports.entries[i];
-
-                    if (import->module == am_erlang) {
-                        if (import->function == am_apply) {
-                            if (import->arity == 2 || import->arity == 3) {
-                                goto restart;
-                            }
-                        }
-                    }
-
-		}
-	    }
-	    break;
-
-#endif
-#if defined(TOP_is_func)
-	case TOP_is_func:
-	    {
-		Eterm mod = *pc++;
-		Eterm func = *pc++;
-		int arity = *pc++;
-
-		ASSERT(instr->a[ap].type == TAG_u);
-		if (instr->a[ap].type != TAG_u) {
-		    goto restart;
-		}
-		i = instr->a[ap].val;
-                ASSERT(i < st->beam.imports.count);
-                {
-                    BeamFile_ImportEntry *import;
-
-                    if (i >= st->beam.imports.count) {
-                        goto restart;
-                    }
-
-                    import = &st->beam.imports.entries[i];
-
-                    if (import->module != mod) {
-                        goto restart;
-                    }
-                    if (import->function != func) {
-                        goto restart;
-                    }
-                    if (import->arity != arity) {
-                        goto restart;
-                    }
-                }
-	    }
-	    break;
-#endif
-	case TOP_set_var:
-	    ASSERT(ap < instr->arity);
-	    i = *pc++;
-	    ASSERT(i < TE_MAX_VARS);
-	    var[i] = instr->a[ap];
-	    break;
-#if defined(TOP_rest_args)
-	case TOP_rest_args:
-	    {
-		int formal_arity = gen_opc[instr->op].arity;
-		num_rest_args = instr->arity - formal_arity;
-		rest_args = instr->a + formal_arity;
-	    }
-	    break;
-#endif
-	case TOP_next_arg:
-	    ap++;
-	    break;
-	case TOP_commit:
-	    instr = instr->next; /* The next_instr was optimized away. */
-	    keep = instr;
-	    break;
-#if defined(TOP_commit_new_instr)
-	case TOP_commit_new_instr:
-            /*
-             * Reuse the last instruction on the left side instead of
-             * allocating a new instruction. Note that this is not
-             * safe if TOP_rest_args has been executed; therefore,
-             * this combined instruction is never used when that is
-             * the case.
-             */
-            ASSERT(instr->a == instr->def_args);
-            keep = instr;
-            instr->op = op = *pc++;
-            instr->arity = gen_opc[op].arity;
-            ap = 0;
-            break;
-#endif
-#if defined(TOP_keep)
-	case TOP_keep:
-	    /* Keep the current instruction unchanged. */
-	    keep = instr;
-	    break;
-#endif
-#if defined(TOP_call)
-	case TOP_call:
-	    {
-		BeamOp** lastp;
-		BeamOp* new_instr;
-
-		i = *pc++;
-                new_instr = erts_beam_execute_transform((unsigned) i, st, var, rest_args);
-		if (new_instr == NULL) {
-		    goto restart;
-		}
-
-		lastp = &new_instr;
-		while (*lastp != NULL) {
-		    lastp = &((*lastp)->next);
-		}
-
-		keep = instr->next; /* The next_instr was optimized away. */
-		*lastp = keep;
-                instr = new_instr;
-	    }
-            break;
-#endif
-	case TOP_end:
-            st->genop = instr;
-	    while (first != keep) {
-		BeamOp* next = first->next;
-		beamopallocator_free_op(&st->op_allocator, first);
-		first = next;
-	    }
-
-	    return TE_OK;
-	    /*
-	     * Note that the instructions are generated in reverse order.
-	     */
-	case TOP_new_instr:
-            {
-                BeamOp* new_instr = beamopallocator_new_op(&st->op_allocator);
-                new_instr->next = instr;
-                instr = new_instr;
-                instr->op = op = *pc++;
-                instr->arity = gen_opc[op].arity;
-                ap = 0;
-            }
-            break;
-#ifdef TOP_rename
-	case TOP_rename:
-	    instr->op = op = *pc++;
-	    instr->arity = gen_opc[op].arity;
-	    return TE_OK;
-#endif
-	case TOP_store_val:
-            instr->a[ap].type = pc[0];
-            instr->a[ap].val = pc[1];
-            pc += 2;
-            break;
-	case TOP_store_var:
-	    i = *pc++;
-	    ASSERT(i < TE_MAX_VARS);
-	    instr->a[ap] = var[i];
-	    break;
-#if defined(TOP_store_rest_args)
-	case TOP_store_rest_args:
-	    {
-		ASSERT(instr->a == instr->def_args);
-		instr->arity = instr->arity + num_rest_args;
-		instr->a = erts_alloc(ERTS_ALC_T_LOADER_TMP,
-		                      instr->arity * sizeof(BeamOpArg));
-		sys_memcpy(instr->a, instr->def_args, ap*sizeof(BeamOpArg));
-		sys_memcpy(instr->a+ap, rest_args, num_rest_args*sizeof(BeamOpArg));
-		ap += num_rest_args;
-	    }
-	    break;
-#endif
-	case TOP_try_me_else:
-	    restart = pc + 1;
-	    restart += *pc++;
-	    ASSERT(*pc < NUM_TOPS); /* Valid instruction? */
-	    break;
-	case TOP_try_me_else_fail:
-	    restart = restart_fail;
-	    break;
-#if defined(TOP_nop)
-	case TOP_nop:
-            break;
-#endif
-	case TOP_fail:
-	    return TE_FAIL;
-#if defined(TOP_skip_unless)
-	case TOP_skip_unless:
-            /*
-             * Note that the caller of transform_engine() guarantees that
-             * there is always a second instruction available.
-             */
-            ASSERT(instr);
-            if (instr->next->op != pc[0]) {
-                /* The second instruction is wrong. Skip ahead. */
-                pc += pc[1] + 2;
-                ASSERT(*pc < NUM_TOPS); /* Valid instruction? */
-            } else {
-                /* Correct second instruction. */
-                pc += 2;
-            }
-	    break;
-#endif
-	default:
-	    ASSERT(0);
-	}
-    }
-}
diff --git a/erts/emulator/internal_doc/beam_makeops.md b/erts/emulator/internal_doc/beam_makeops.md
index 563ad200f7..9c127517dc 100644
--- a/erts/emulator/internal_doc/beam_makeops.md
+++ b/erts/emulator/internal_doc/beam_makeops.md
@@ -379,16 +379,12 @@ Give the option `-emulator` to produce output files for the emulator.
 The following output files will be generated in the output directory.
 
 * `beam_opcodes.c` - Defines static data used by the loader
-(`beam_load.c`).  Data about generic instructions, specific
-instructions (including how to pack their operands), and
-transformation rules are all part of this file.
+(`beam_load.c`), providing information about generic and specific
+instructions, as well as all C code for the transformation rules.
 
 * `beam_opcodes.h` - Miscellaneous preprocessor definitions, mainly
 used by `beam_load.c` but also by `beam_{hot,warm,cold}.h`.
 
-* `beam_transform.c` - Implementation of guard constraints and generators
-called from transformation rules.
-
 For the traditional BEAM interpreter, the following files are also
 generated:
 
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops
index aee81dd420..796fff7182 100755
--- a/erts/emulator/utils/beam_makeops
+++ b/erts/emulator/utils/beam_makeops
@@ -131,13 +131,7 @@ my @if_line;
 #
 my $te_max_vars = 0;		# Max number of variables ever needed.
 my %gen_transform;
-my %match_engine_ops;		# All opcodes for the match engine.
-my %gen_transform_offset;
 my @transformations;
-my @call_table;
-my %call_table;
-my @pred_table;
-my %pred_table;
 
 # Operand types for generic instructions.
 
@@ -338,12 +332,6 @@ sub define_type_bit {
     define_type_bit('H', $type_bit{'u'});
 }
 
-#
-# Pre-define the 'fail' instruction. It is used internally
-# by the 'try_me_else_fail' instruction.
-#
-$match_engine_ops{'TOP_fail'} = 1;
-
 #
 # Sanity checks.
 #
@@ -866,6 +854,14 @@ sub emulator_output {
     open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
     comment('C');
     include_files();
+    print '#include "erl_term.h"', "\n";
+    print '#include "erl_map.h"', "\n";
+    print '#include "big.h"', "\n";
+    print '#include "erl_bits.h"', "\n";
+    print '#include "erl_binary.h"', "\n";
+    print '#include "beam_transform_helpers.h"', "\n";
+    print '#include "erl_global_literals.h"', "\n";
+    print "\n";
 
     print "const char tag_to_letter[] = {\n  ";
     for ($i = 0; $i < length($genop_types); $i++) {
@@ -994,11 +990,10 @@ 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, 0);
 	} else {
 	    my($key) = "$name/$arity";
-	    my($tr) = defined $gen_transform_offset{$key} ?
-		$gen_transform_offset{$key} : -1;
+	    my($tr) = defined $gen_transform{$key} ? 1 : 0;
 	    my($spec_op) = $gen_to_spec{$key};
 	    my($num_specific) = $num_specific{$key};
 	    defined $spec_op or
@@ -1075,17 +1070,6 @@ sub emulator_output {
     }
     print "\n#define BEAM_NUM_TAGS $tag_num\n\n";
 
-    $i = 0;
-    foreach (sort keys %match_engine_ops) {
-	print "#define $_ $i\n";
-	$i++;
-    }
-    print "#define NUM_TOPS $i\n";
-    print "\n";
-
-    print "#define TE_MAX_VARS $te_max_vars\n";
-    print "\n";
-
     print "extern const char tag_to_letter[];\n";
     print "extern const Uint op_transform[];\n";
     print "\n";
@@ -1128,28 +1112,6 @@ sub emulator_output {
 
     print "#endif\n";
 
-
-    #
-    # Extension of transform engine.
-    #
-
-    $name = "$outdir/beam_transform.c";
-    open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
-    comment('C');
-    include_files();
-    print '#include "erl_term.h"', "\n";
-    print '#include "erl_map.h"', "\n";
-    print '#include "big.h"', "\n";
-    print '#include "erl_bits.h"', "\n";
-    print '#include "erl_binary.h"', "\n";
-    print '#include "beam_transform_helpers.h"', "\n";
-    print '#include "erl_global_literals.h"', "\n";
-    print "\n";
-    gen_tr_code('pred.');
-    gen_tr_func('int', 'erts_beam_eval_predicate', @pred_table);
-    gen_tr_code('gen.');
-    gen_tr_func('BeamOp*', 'erts_beam_execute_transform', @call_table);
-
     #
     # Implementation of operations for emulator.
     #
@@ -2702,6 +2664,12 @@ sub tr_gen {
 	tr_gen_to($line, $orig_transform, $so_far, @$to_ref);
     }
 
+    #
+    # Print predicate and generation functions.
+    #
+    gen_tr_code('pred.');
+    gen_tr_code('gen.');
+
     #
     # Group instructions.
     #
@@ -2712,36 +2680,360 @@ sub tr_gen {
     #
     # Print the generated transformation engine.
     #
-    my($offset) = 0;
-    print "const Uint op_transform[] = {\n";
+
+    my $vars = join(", ", map { "v$_" } 0..$te_max_vars-1);
+    print <<"END";
+int erts_transform_engine(LoaderState* st) {
+  BeamOpArg $vars;
+  BeamOp* first = st->genop;
+  BeamOp* instr = first;
+  BeamOp* keep;
+  BeamOpArg* rest_args;
+  int num_rest_args;
+END
+
+    my $label = 0;
+    my $ap = 0;
+    my $ip = 1;
+    my $need_label = 0;
+
+    print "  switch (first->op) {\n";
     foreach $key (sort keys %gen_transform) {
-	$gen_transform_offset{$key} = $offset;
         my $lref = $gen_transform{$key};
 
+        my($name,$arity) = $key =~ m@^([^/]+)/(\d+)$@;
+        print "    case $gen_opnum{$name,$arity}: /* $key */\n";
+        $need_label = 0;
+
         for (my $i = 0; $i < @$lref; $i++) {
             my(undef,undef,undef,$comment,@instr) = @{${$lref}[$i]};
             $comment =~ s/\n(.)/\n    $1/g;
             print $comment;
 
+            if ($need_label) {
+                print <<"END";
+  fail$label:
+    instr = first;
+END
+            }
+            $label++;
+            $need_label = 1;
+            $ap = 0;
+            $ip = 0;
+            my $fail_action = "return TE_FAIL";
+
             foreach $instr (@instr) {
                 my($size, $instr_ref, $comment) = @$instr;
                 my($op, @args) = @$instr_ref;
-                print "    ";
-                $op = "TOP_$op";
-                $match_engine_ops{$op} = 1;
-                if ($comment ne '') {
-                    printf "%-30s /* %s */\n", (join(", ", ($op, @args)) . ","),
-                        $comment;
-                } else {
-                    print join(", ", ($op, @args)), ",\n";
+                if ($op eq 'next_arg') {
+                    $ap++;
+                } elsif ($op eq 'next_instr') {
+                    $ap = 0;
+                    $ip++;
+                } elsif ($op eq 'new_instr') {
+                    $ap = 0;
+                } elsif ($op eq 'commit') {
+                    $ap = 0;
+                } elsif ($op eq 'commit_new_instr') {
+                    $ap = 0;
+                    $ip--;
+                } elsif ($op eq 'keep') {
+                    $ip--;
+                } elsif ($op eq 'try_me_else') {
+                    $fail_action = "goto fail$label";
+                } elsif ($op eq 'skip_unless') {
+                    $fail_action = "goto fail$label";
+                    $need_label = 0;
                 }
-                $offset += $size;
+                gen_te_instr($ap, $ip, $fail_action, $comment, $op, @args);
             }
         }
-	print "\n";
+        print "\n";
+    }
+    print "    default: ASSERT(0); return TE_FAIL;\n";
+    print "  }\n";
+    print "}\n\n";
+}
+
+sub gen_te_instr {
+    my($ap,$ip,$fail_action,$comment,$op,@args) = @_;
+
+    if ($op eq 'next_arg') {
+        ;
+    } elsif ($op eq 'nop') {
+        ;
+    } elsif ($op eq 'try_me_else') {
+        ;
+    } elsif ($op eq 'try_me_else_fail') {
+        ;
+    } elsif ($op eq 'skip_unless') {
+        my($instr,$count) = @args;
+        my($fail_label) = $fail_action =~ /^goto fail(\d+)/;
+        if (defined $fail_label) {
+            $fail_action = "goto fail" . ($fail_label+$count);
+        }
+        print <<"END";
+    /*
+     * Note that the caller of transform_engine() guarantees that
+     * there is always a second instruction available.
+     */
+    ASSERT(instr);
+    if (instr->next->op != $instr) {
+        /* The second instruction is wrong. Skip ahead. */
+        $fail_action;
+    }
+END
+    } elsif ($op eq 'set_var') {
+        my $var = "v$args[0]";
+        print <<"END";
+    $var = instr->a[$ap]; /* $comment */
+END
+    } elsif ($op eq 'is_bif') {
+        my $bif_number = $args[0];
+        my $specific_bif_action = "";
+        my $bif_comment;
+        if ($bif_number eq '-1') {
+            $bif_comment = "Is $comment a BIF?";
+        } else {
+            $bif_comment = "Is $comment $bif_number?";
+            $specific_bif_action = <<"END";
+        if (entry != &bif_table[$bif_number]) {
+          $fail_action; /* Not $bif_number */
+        }
+END
+        }
+        print <<"END";
+    /* $bif_comment */
+    ASSERT(instr->a[$ap].type == TAG_u);
+    if (instr->a[$ap].type != TAG_u) {
+      $fail_action;
+    } else {
+      int i = instr->a[$ap].val;
+      ASSERT(i < st->beam.imports.count);
+      if (i >= st->beam.imports.count) {
+        $fail_action;
+      } else {
+        BifEntry *entry = st->bif_imports[i];
+
+        if (!entry) {
+          $fail_action; /* Not a BIF */
+        }
+$specific_bif_action
+      }
+    }
+END
+    } elsif ($op eq 'is_not_bif') {
+        my $bif_number = $args[0];
+        print <<"END";
+    /* Is $comment not a BIF? */
+    {
+      int i = instr->a[$ap].val;
+
+      /*
+       * In debug build, the type must be 'u'.
+       */
+      ASSERT(instr->a[$ap].type == TAG_u);
+      if (instr->a[$ap].type != TAG_u) {
+        $fail_action;
+      } else if (i < st->beam.imports.count) {
+        BeamFile_ImportEntry *import;
+
+        if (st->bif_imports[i]) {
+          $fail_action;
+        }
+
+        /* erlang:apply/2,3 are strange. They exist as (dummy) BIFs
+         * so that they are included in the export table before
+         * the erlang module is loaded. They also exist in the
+         * erlang module as functions. When used in code, a special
+         * Beam instruction is used.
+         *
+         * Below we recognize erlang:apply/2,3 as special. This is
+         * necessary because after setting a trace pattern on
+         * them, you can no longer see from the export entry that
+         * they are special. */
+        import = &st->beam.imports.entries[i];
+
+        if (import->module == am_erlang) {
+          if (import->function == am_apply) {
+            if (import->arity == 2 || import->arity == 3) {
+              $fail_action;
+            }
+          }
+        }
+      }
+    }
+END
+    } elsif ($op eq 'is_eq') {
+        my $val = $args[0];
+        print <<"END";
+    /* Test value */
+    if (instr->a[$ap].val != $val) {
+      $fail_action;
+    }
+END
+    } elsif ($op eq 'is_func') {
+        my($mod,$name,$arity) = @args;
+        print <<"END";
+    /* Is $comment the function $mod:$name/$arity? */
+    ASSERT(instr->a[$ap].type == TAG_u);
+    if (instr->a[$ap].type != TAG_u) {
+      $fail_action;
+    } else {
+      int i = instr->a[$ap].val;
+      BeamFile_ImportEntry* import;
+      ASSERT(i < st->beam.imports.count);
+      if (i >= st->beam.imports.count) {
+        $fail_action;
+      }
+      import = &st->beam.imports.entries[i];
+      if (import->module != $mod || import->function != $name || import->arity != $arity) {
+        $fail_action;
+      }
+    }
+END
+    } elsif ($op eq 'is_type') {
+        my $mask = $args[0];
+        print <<"END";
+    /* Test type */
+    if (((1 << instr->a[$ap].type) & $mask) == 0) { /* $comment */
+      $fail_action;
+    }
+END
+    } elsif ($op eq 'next_instr') {
+        my $expected = $args[0];
+        my $window_check = "ASSERT(instr)";
+        if ($ip > 1) {
+            $window_check = "if (instr == NULL) return TE_SHORT_WINDOW";
+        }
+        print <<"END";
+    /* Advance to next instruction */
+    instr = instr->next;
+    $window_check;
+    if (instr->op != $expected) { /* $comment */
+      $fail_action;
+    }
+END
+    } elsif ($op eq 'call') {
+        my($name,@vars) = @args;
+        my $call = $name . "(" . join(", ", ("st", @vars)) . ")";
+        print <<"END";
+    /* Call generator $name() */
+    {
+      BeamOp** lastp;
+      BeamOp* new_instr = $call;
+
+      if (new_instr == NULL) {
+        $fail_action;
+      }
+
+      keep = instr->next; /* The next_instr was optimized away. */
+
+      lastp = &new_instr;
+      while (*lastp != NULL) {
+          lastp = &((*lastp)->next);
+      }
+
+      *lastp = keep;
+      instr = new_instr;
+    }
+END
+    } elsif ($op eq 'pred') {
+        my($name,@vars) = @args;
+        my $pred = "$name(" . join(", ", ("st", @vars)) . ")";
+        print <<"END";
+    /* Call predicate $name() */
+    if (!$pred) {
+      $fail_action;
+    }
+END
+    } elsif ($op eq 'rest_args') {
+        my($formal_arity) = @args;
+        print <<"END";
+    /* Store dynamic arguments ($comment) */
+    num_rest_args = instr->arity - $formal_arity;
+    rest_args = &instr->a[$formal_arity];
+END
+    } elsif ($op eq 'commit') {
+        print <<"END";
+    /* $comment */
+    keep = instr = instr->next;
+END
+    } elsif ($op eq 'commit_new_instr') {
+        my($instr_op) = @args;
+        my $arity = $gen_arity{$gen_opname[$instr_op]};
+        print <<"END";
+    /* $comment; reusing last instruction on the left-hand side */
+    ASSERT(instr->a == instr->def_args);
+    keep = instr;
+    instr->op = $instr_op;
+    instr->arity = $arity;
+END
+    } elsif ($op eq 'keep') {
+        print <<"END";
+    /* Keep the current instruction unchanged */
+    keep = instr;
+END
+    } elsif ($op eq 'new_instr') {
+        my($instr_op) = @args;
+        my $arity = $gen_arity{$gen_opname[$instr_op]};
+        print <<"END";
+    /* Create instruction: $comment */
+    {
+      BeamOp* new_instr = beamopallocator_new_op(&st->op_allocator);
+      new_instr->next = instr;
+      instr = new_instr;
+      instr->op = $instr_op;
+      instr->arity = $arity;
+    }
+END
+    } elsif ($op eq 'rename') {
+        my($instr_op) = @args;
+        my $arity = $gen_arity{$gen_opname[$instr_op]};
+        print <<"END";
+    /* Rename instruction keeping the arguments */
+    instr->op = $instr_op;
+    instr->arity = $arity;
+    return TE_OK;
+END
+    } elsif ($op eq 'store_var') {
+        my $var = $args[0];
+        print "    instr->a[$ap] = v$var; /* $comment */\n";
+    } elsif ($op eq 'store_val') {
+        my($type,$val) = @args;
+        print <<"END";
+    /* Store value $comment */
+    instr->a[$ap].type = $type;
+    instr->a[$ap].val = $val;
+END
+    } elsif ($op eq 'store_rest_args') {
+        my($type,$val) = @args;
+        print <<"END";
+    /* Store dynamic arguments ($comment) */
+    ASSERT(instr->a == instr->def_args);
+    instr->arity = instr->arity + num_rest_args;
+    instr->a = erts_alloc(ERTS_ALC_T_LOADER_TMP,
+                          instr->arity * sizeof(BeamOpArg));
+    sys_memcpy(instr->a, instr->def_args, $ap * sizeof(BeamOpArg));
+    sys_memcpy(instr->a+$ap, rest_args, num_rest_args*sizeof(BeamOpArg));
+END
+    } elsif ($op eq 'end') {
+        print <<"END";
+    /* End of transformation */
+    st->genop = instr;
+    while (first != keep) {
+      BeamOp* next = first->next;
+      beamopallocator_free_op(&st->op_allocator, first);
+      first = next;
+    }
+    return TE_OK;
+END
+    } elsif ($op eq 'fail') {
+        print "/* Fail transformation */\n";
+        print "return TE_FAIL;\n";
+    } else {
+        error("Unhandled instruction: $op @args");
     }
-    print starred_comment("Total number of words: $offset");
-    print "};\n\n";
 }
 
 sub tr_gen_from {
@@ -2786,7 +3078,7 @@ sub tr_gen_from {
 		    unless defined $var{$var};
                 push @vars, $var;
 		if ($var_type{$var} eq 'scalar') {
-		    push(@args, "var[$var{$var}]");
+		    push(@args, "v$var{$var}");
                     push @param_types, 'BeamOpArg';
 		} else {
 		    push(@args, "rest_args");
@@ -2796,8 +3088,7 @@ sub tr_gen_from {
             my $c_name = "pred.$name";
             $c_param_types{$c_name} = \@param_types;
             $c_code_used{$c_name} = 1;
-	    my $pi = next_tr_index(\@{pred_table}, \%pred_table, $name, @args);
-            my $op = make_op("$name()", 'pred', $pi);
+            my $op = make_op("$name()", 'pred', $name, @args);
             my @slots = grep(/^\d+/, map { $var{$_} } @vars);
 	    op_slot_usage($op, @slots);
 	    push(@code, $op);
@@ -2814,9 +3105,9 @@ sub tr_gen_from {
 
 	push(@code, make_op("$name/$arity", 'next_instr', $opnum));
         push @instrs, "$name/$arity";
+        my $arg = 0;
 	foreach $op (@ops) {
 	    my($var, $type, $type_val, $cond, $val) = @$op;
-	    my $ignored_var = "$var (ignored)";
 
 	    if ($type ne '' && $type ne '*') {
 		$may_fail = 1;
@@ -2826,7 +3117,6 @@ sub tr_gen_from {
 		# their own built-in type test and don't need to
 		# be guarded with a type test instruction.
 		#
-		$ignored_var = '';
 		unless ($cond eq 'is_bif' or
 			$cond eq 'is_not_bif' or
 			$cond eq 'is_func') {
@@ -2840,16 +3130,18 @@ sub tr_gen_from {
 		}
 	    }
 
+            $arg++;
+            my $var_comment = "variable $var";
+            $var_comment = "argument $arg"
+                if $var eq '';
 	    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));
+                push @code, make_op($var_comment, $cond, "am_$m", "am_$f", $a);
 	    } elsif ($cond ne '') {
-		$ignored_var = '';
 		$may_fail = 1;
-		push(@code, make_op('', "$cond", $val));
+
+                push @code, make_op($var_comment, $cond, $val);
 	    }
 
 	    if ($var ne '') {
@@ -2866,19 +3158,17 @@ sub tr_gen_from {
 			      "a transformation")
 			    if $type eq 'array';
 		    }
-		    $ignored_var = '';
 		    $var{$var} = 'unnumbered';
 		    $var_type{$var} = 'array';
-		    push(@code, make_op($var, 'rest_args'));
+                    push @code, make_op($var, 'rest_args', $arity);
 		} else {
-		    $ignored_var = '';
 		    $var_type{$var} = 'scalar';
 		    $var{$var} = $var_num;
 		    $var_num++;
 		    push(@code, make_op($var, 'set_var', $var{$var}));
 		}
 	    }
-            push(@code, make_op($ignored_var, 'next_arg'));
+            push(@code, make_op('', 'next_arg'));
 	}
 
 	# Remove redundant 'next_arg' instructions before the end
@@ -2889,7 +3179,8 @@ sub tr_gen_from {
     #
     # Insert the commit operation.
     #
-    push(@code, make_op($may_fail ? '' : 'always reached', 'commit'));
+    push(@code, make_op($may_fail ? 'This rule succeeds' :
+                        'This rule always succeeds', 'commit'));
 
     $te_max_vars = $var_num
 	if $te_max_vars < $var_num;
@@ -2926,7 +3217,7 @@ sub tr_gen_to {
 		error($where, "variable '$var' unbound")
 		    unless defined $var{$var};
 		if ($var_type{$var} eq 'scalar') {
-		    push @args, "var[$var{$var}]";
+		    push @args, "v$var{$var}";
                     push @param_types, 'BeamOpArg';
 		} else {
 		    push @args, "rest_args";
@@ -2937,9 +3228,7 @@ sub tr_gen_to {
             $c_param_types{$c_name} = \@param_types;
             $c_code_used{$c_name} = 1;
 	    pop(@code);	# Get rid of 'commit' instruction
-	    my $index = next_tr_index(\@call_table, \%call_table,
-				      $name, @args);
-	    my $op = make_op("$name()", 'call', $index);
+	    my $op = make_op("$name()", 'call', $name, @args);
 	    my @slots = grep(/^\d+/, map { $var{$_} } @ops);
 	    op_slot_usage($op, @slots);
 	    push(@code, $op);
@@ -3062,7 +3351,7 @@ sub group_tr {
             if ($i == $#{$lref}) {
                 unshift @c, make_op('', 'try_me_else_fail');
             } else {
-                unshift @c, make_op('', 'try_me_else', code_len(@c));
+                unshift @c, make_op('', 'try_me_else');
             }
         }
         ${$lref}[$i] = [$first,$second,$cannot_fail,$comment,@c];
@@ -3083,7 +3372,7 @@ sub group_tr {
         for ($j = $i; $j < @$lref; $j++) {
             my(undef,$other,undef,undef,@c) = @{${$lref}[$j]};
             last unless defined $other and $other eq $current;
-            $skip_len += code_len(@c);
+            $skip_len++;
         }
 
         if ($j > $i + 1) {
@@ -3097,13 +3386,11 @@ sub group_tr {
             splice @$lref, $i, 0, (['','',1,$comment,$op]);
             $i = $j + 1;
             if ($j == $#{$lref}) {
-                my($first,$second,$cannot_fail,$comment,@c) = @{${$lref}[$j]};
-                push @c, make_op('wrong second instruction', 'fail');
-                ${$lref}[$j] = [$first,$second,$cannot_fail,$comment,@c];
+                my(@c) = (make_op('wrong second instruction', 'fail'));
+                push @$lref, ['','','','',@c];
             }
         }
     }
-
     $lref;
 }
 
@@ -3162,6 +3449,7 @@ sub combine_commit {
         if ($op eq 'rest_args') {
             return;
         } elsif ($op eq 'new_instr' and is_instr($$ref[$i-1], 'commit')) {
+            $comment = get_comment($$ref[$i-1]);
             my $op = make_op($comment, 'commit_new_instr', @args);
             splice @$ref, $i - 1, 2, ($op);
         }
@@ -3295,16 +3583,6 @@ sub gen_tr_code {
     }
 }
 
-sub code_len {
-    my($sum) = 0;
-    my($ref);
-
-    foreach $ref (@_) {
-	$sum += $$ref[0];
-    }
-    $sum;
-}
-
 sub make_op {
     my($comment, @op) = @_;
     [scalar(@op), [@op], $comment, []];
@@ -3331,34 +3609,6 @@ sub starred_comment {
     "\n/*" . join("\n * ", '', @_) . "\n */\n\n";
 }
 
-sub next_tr_index {
-    my($lref,$href,$name,@args) = @_;
-    my $code = "return $name(" . join(', ', 'st', @args) . ");\n";
-    my $index;
-
-    if (defined $$href{$code}) {
-	$index = $$href{$code};
-    } else {
-	$index = scalar(@$lref);
-	push(@$lref, $code);
-	$$href{$code} = $index;
-    }
-    $index;
-}
-
-sub gen_tr_func {
-    my($type,$name,@call_table) = @_;
-
-    print "$type $name(unsigned int op, LoaderState* st, BeamOpArg var[], BeamOpArg* rest_args) {\n";
-    print "  switch (op) {\n";
-    for (my $i = 0; $i < @call_table; $i++) {
-	print "    case $i: $call_table[$i]";
-    }
-    print qq[    default: erts_exit(ERTS_ABORT_EXIT, "$name: invalid op %d\\n", op);];
-    print "  }\n";
-    print "}\n\n";
-}
-
 sub include_files() {
     print "#ifdef HAVE_CONFIG_H\n";
     print "#  include \"config.h\"\n";
-- 
2.35.3

Places

File 1025-Generate-C-code-for-the-transformation-engine.patch of Package erlang

Places