aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--erts/emulator/beam/beam_emu.c87
-rw-r--r--erts/emulator/beam/beam_load.c129
-rw-r--r--erts/emulator/beam/ops.tab102
-rwxr-xr-xerts/emulator/utils/beam_makeops188
4 files changed, 257 insertions, 249 deletions
diff --git a/erts/emulator/beam/beam_emu.c b/erts/emulator/beam/beam_emu.c
index 4b5b5cbdaa..5691f7aec1 100644
--- a/erts/emulator/beam/beam_emu.c
+++ b/erts/emulator/beam/beam_emu.c
@@ -4863,92 +4863,6 @@ void process_main(void)
}
/*
- * Instructions for allocating on the message area.
- */
-
- OpCase(i_global_cons):
- {
- BeamInstr *next;
-#ifdef HYBRID
- Eterm *hp;
-
- PreFetch(0,next);
- TestGlobalHeap(2,2,hp);
- hp[0] = r(0);
- hp[1] = x(1);
- r(0) = make_list(hp);
-#ifndef INCREMENTAL
- global_htop += 2;
-#endif
- NextPF(0,next);
-#else
- PreFetch(0,next);
- c_p->freason = EXC_INTERNAL_ERROR;
- goto find_func_info;
-#endif
- }
-
- OpCase(i_global_tuple):
- {
- BeamInstr *next;
- int len;
-#ifdef HYBRID
- Eterm list;
- Eterm *hp;
-#endif
-
- if ((len = list_length(r(0))) < 0) {
- goto badarg;
- }
-
- PreFetch(0,next);
-#ifdef HYBRID
- TestGlobalHeap(len + 1,1,hp);
- list = r(0);
- r(0) = make_tuple(hp);
- *hp++ = make_arityval(len);
- while(is_list(list))
- {
- Eterm* cons = list_val(list);
- *hp++ = CAR(cons);
- list = CDR(cons);
- }
-#ifndef INCREMENTAL
- global_htop += len + 1;
-#endif
- NextPF(0,next);
-#else
- c_p->freason = EXC_INTERNAL_ERROR;
- goto find_func_info;
-#endif
- }
-
- OpCase(i_global_copy):
- {
- BeamInstr *next;
- PreFetch(0,next);
-#ifdef HYBRID
- if (!IS_CONST(r(0)))
- {
- BM_SWAP_TIMER(system,copy);
- SWAPOUT;
- reg[0] = r(0);
- reg[1] = NIL;
- r(0) = copy_struct_lazy(c_p,r(0),0);
- ASSERT(ma_src_top == 0);
- ASSERT(ma_dst_top == 0);
- ASSERT(ma_offset_top == 0);
- SWAPIN;
- BM_SWAP_TIMER(copy,system);
- }
- NextPF(0,next);
-#else
- c_p->freason = EXC_INTERNAL_ERROR;
- goto find_func_info;
-#endif
- }
-
- /*
* New floating point instructions.
*/
@@ -5241,7 +5155,6 @@ void process_main(void)
OpCase(int_code_end):
OpCase(label_L):
- OpCase(too_old_compiler):
OpCase(on_load):
OpCase(line_I):
erl_exit(1, "meta op\n");
diff --git a/erts/emulator/beam/beam_load.c b/erts/emulator/beam/beam_load.c
index 16dd5795c7..de4b32b238 100644
--- a/erts/emulator/beam/beam_load.c
+++ b/erts/emulator/beam/beam_load.c
@@ -1887,14 +1887,6 @@ load_code(LoaderState* stp)
}
/*
- * Special error message instruction.
- */
- if (stp->genop->op == genop_too_old_compiler_0) {
- LoadError0(stp, "please re-compile this module with an "
- ERLANG_OTP_RELEASE " compiler");
- }
-
- /*
* From the collected generic instruction, find the specific
* instruction.
*/
@@ -1945,7 +1937,27 @@ load_code(LoaderState* stp)
ERLANG_OTP_RELEASE " compiler ");
}
- LoadError0(stp, "no specific operation found");
+ /*
+ * Some generic instructions should have a special
+ * error message.
+ */
+ switch (stp->genop->op) {
+ case genop_too_old_compiler_0:
+ LoadError0(stp, "please re-compile this module with an "
+ ERLANG_OTP_RELEASE " compiler");
+ case genop_unsupported_guard_bif_3:
+ {
+ Eterm Mod = (Eterm) stp->genop->a[0].val;
+ Eterm Name = (Eterm) stp->genop->a[1].val;
+ Uint arity = (Uint) stp->genop->a[2].val;
+ FREE_GENOP(stp, stp->genop);
+ stp->genop = 0;
+ LoadError3(stp, "unsupported guard BIF: %T:%T/%d\n",
+ Mod, Name, arity);
+ }
+ default:
+ LoadError0(stp, "no specific operation found");
+ }
}
stp->specific_op = specific;
@@ -2409,6 +2421,8 @@ load_code(LoaderState* stp)
#define no_fpe_signals(St) 0
#endif
+#define never(St) 0
+
/*
* Predicate that tests whether a jump table can be used.
*/
@@ -3664,10 +3678,7 @@ gen_guard_bif1(LoaderState* stp, GenOpArg Fail, GenOpArg Live, GenOpArg Bif,
BifFunction bf;
NEW_GENOP(stp, op);
- op->op = genop_i_gc_bif1_5;
- op->arity = 5;
- op->a[0] = Fail;
- op->a[1].type = TAG_u;
+ op->next = NULL;
bf = stp->import[Bif.val].bf;
/* The translations here need to have a reverse counterpart in
beam_emu.c:translate_gc_bif for error handling to work properly. */
@@ -3688,19 +3699,30 @@ gen_guard_bif1(LoaderState* stp, GenOpArg Fail, GenOpArg Live, GenOpArg Bif,
} else if (bf == trunc_1) {
op->a[1].val = (BeamInstr) (void *) erts_gc_trunc_1;
} else {
- abort();
+ op->op = genop_unsupported_guard_bif_3;
+ op->arity = 3;
+ op->a[0].type = TAG_a;
+ op->a[0].val = stp->import[Bif.val].module;
+ op->a[1].type = TAG_a;
+ op->a[1].val = stp->import[Bif.val].function;
+ op->a[2].type = TAG_u;
+ op->a[2].val = stp->import[Bif.val].arity;
+ return op;
}
+ op->op = genop_i_gc_bif1_5;
+ op->arity = 5;
+ op->a[0] = Fail;
+ op->a[1].type = TAG_u;
op->a[2] = Src;
op->a[3] = Live;
op->a[4] = Dst;
- op->next = NULL;
return op;
}
/*
- * This is used by the ops.tab rule that rewrites gc_bifs with two parameters
+ * This is used by the ops.tab rule that rewrites gc_bifs with two parameters.
* The instruction returned is then again rewritten to an i_load instruction
- * folowed by i_gc_bif2_jIId, to handle literals properly.
+ * followed by i_gc_bif2_jIId, to handle literals properly.
* As opposed to the i_gc_bif1_jIsId, the instruction i_gc_bif2_jIId is
* always rewritten, regardless of if there actually are any literals.
*/
@@ -3712,31 +3734,39 @@ gen_guard_bif2(LoaderState* stp, GenOpArg Fail, GenOpArg Live, GenOpArg Bif,
BifFunction bf;
NEW_GENOP(stp, op);
- op->op = genop_ii_gc_bif2_6;
- op->arity = 6;
- op->a[0] = Fail;
- op->a[1].type = TAG_u;
+ op->next = NULL;
bf = stp->import[Bif.val].bf;
/* The translations here need to have a reverse counterpart in
beam_emu.c:translate_gc_bif for error handling to work properly. */
if (bf == binary_part_2) {
op->a[1].val = (BeamInstr) (void *) erts_gc_binary_part_2;
} else {
- abort();
+ op->op = genop_unsupported_guard_bif_3;
+ op->arity = 3;
+ op->a[0].type = TAG_a;
+ op->a[0].val = stp->import[Bif.val].module;
+ op->a[1].type = TAG_a;
+ op->a[1].val = stp->import[Bif.val].function;
+ op->a[2].type = TAG_u;
+ op->a[2].val = stp->import[Bif.val].arity;
+ return op;
}
+ op->op = genop_ii_gc_bif2_6;
+ op->arity = 6;
+ op->a[0] = Fail;
+ op->a[1].type = TAG_u;
op->a[2] = S1;
op->a[3] = S2;
op->a[4] = Live;
op->a[5] = Dst;
- op->next = NULL;
return op;
}
/*
- * This is used by the ops.tab rule that rewrites gc_bifs with three parameters
+ * This is used by the ops.tab rule that rewrites gc_bifs with three parameters.
* The instruction returned is then again rewritten to a move instruction that
* uses r[0] for temp storage, followed by an i_load instruction,
- * folowed by i_gc_bif3_jIsId, to handle literals properly. Rewriting
+ * followed by i_gc_bif3_jIsId, to handle literals properly. Rewriting
* always occur, as with the gc_bif2 counterpart.
*/
static GenOp*
@@ -3747,18 +3777,27 @@ gen_guard_bif3(LoaderState* stp, GenOpArg Fail, GenOpArg Live, GenOpArg Bif,
BifFunction bf;
NEW_GENOP(stp, op);
- op->op = genop_ii_gc_bif3_7;
- op->arity = 7;
- op->a[0] = Fail;
- op->a[1].type = TAG_u;
+ op->next = NULL;
bf = stp->import[Bif.val].bf;
/* The translations here need to have a reverse counterpart in
beam_emu.c:translate_gc_bif for error handling to work properly. */
if (bf == binary_part_3) {
op->a[1].val = (BeamInstr) (void *) erts_gc_binary_part_3;
} else {
- abort();
+ op->op = genop_unsupported_guard_bif_3;
+ op->arity = 3;
+ op->a[0].type = TAG_a;
+ op->a[0].val = stp->import[Bif.val].module;
+ op->a[1].type = TAG_a;
+ op->a[1].val = stp->import[Bif.val].function;
+ op->a[2].type = TAG_u;
+ op->a[2].val = stp->import[Bif.val].arity;
+ return op;
}
+ op->op = genop_ii_gc_bif3_7;
+ op->arity = 7;
+ op->a[0] = Fail;
+ op->a[1].type = TAG_u;
op->a[2] = S1;
op->a[3] = S2;
op->a[4] = S3;
@@ -4225,6 +4264,7 @@ transform_engine(LoaderState* st)
GenOp* instr;
Uint* pc;
int rval;
+ static Uint restart_fail[1] = {TOP_fail};
ASSERT(gen_opc[st->genop->op].transform != -1);
pc = op_transform + gen_opc[st->genop->op].transform;
@@ -4238,7 +4278,6 @@ transform_engine(LoaderState* st)
ASSERT(restart != NULL);
pc = restart;
ASSERT(*pc < NUM_TOPS); /* Valid instruction? */
- ASSERT(*pc == TOP_try_me_else || *pc == TOP_fail);
instr = st->genop;
#define RETURN(r) rval = (r); goto do_return;
@@ -4251,7 +4290,9 @@ transform_engine(LoaderState* st)
op = *pc++;
switch (op) {
- case TOP_is_op:
+ case TOP_next_instr:
+ instr = instr->next;
+ ap = 0;
if (instr == NULL) {
/*
* We'll need at least one more instruction to decide whether
@@ -4438,10 +4479,6 @@ transform_engine(LoaderState* st)
case TOP_next_arg:
ap++;
break;
- case TOP_next_instr:
- instr = instr->next;
- ap = 0;
- break;
case TOP_commit:
instr = instr->next; /* The next_instr was optimized away. */
@@ -4459,8 +4496,8 @@ transform_engine(LoaderState* st)
#endif
break;
-#if defined(TOP_call)
- case TOP_call:
+#if defined(TOP_call_end)
+ case TOP_call_end:
{
GenOp** lastp;
GenOp* new_instr;
@@ -4497,7 +4534,7 @@ transform_engine(LoaderState* st)
*lastp = st->genop;
st->genop = new_instr;
}
- break;
+ RETURN(TE_OK);
#endif
case TOP_new_instr:
/*
@@ -4506,12 +4543,10 @@ transform_engine(LoaderState* st)
NEW_GENOP(st, instr);
instr->next = st->genop;
st->genop = instr;
+ instr->op = op = *pc++;
+ instr->arity = gen_opc[op].arity;
ap = 0;
break;
- case TOP_store_op:
- instr->op = *pc++;
- instr->arity = *pc++;
- break;
case TOP_store_type:
i = *pc++;
instr->a[ap].type = i;
@@ -4521,21 +4556,25 @@ transform_engine(LoaderState* st)
i = *pc++;
instr->a[ap].val = i;
break;
- case TOP_store_var:
+ case TOP_store_var_next_arg:
i = *pc++;
ASSERT(i < TE_MAX_VARS);
instr->a[ap].type = var[i].type;
instr->a[ap].val = var[i].val;
+ ap++;
break;
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;
case TOP_end:
RETURN(TE_OK);
case TOP_fail:
- RETURN(TE_FAIL)
+ RETURN(TE_FAIL);
default:
ASSERT(0);
}
diff --git a/erts/emulator/beam/ops.tab b/erts/emulator/beam/ops.tab
index 538f0b94af..34bd5d0653 100644
--- a/erts/emulator/beam/ops.tab
+++ b/erts/emulator/beam/ops.tab
@@ -25,30 +25,12 @@
# instruction transformations; thus, they never occur in BEAM files.
#
-# Special instruction used to generate an error message when
-# trying to load a module compiled by the V1 compiler (R5 & R6).
-# (Specially treated in beam_load.c.)
+# The too_old_compiler/0 instruction is specially handled in beam_load.c
+# to produce a user-friendly message informing the user that the module
+# needs to be re-compiled with a modern compiler.
too_old_compiler/0
-too_old_compiler
-
-#
-# Obsolete instruction usage follow. (Nowdays we use f with
-# a zero label instead of p.)
-#
-
-is_list p S => too_old_compiler
-is_nonempty_list p R => too_old_compiler
-is_nil p R => too_old_compiler
-
-is_tuple p S => too_old_compiler
-test_arity p S Arity => too_old_compiler
-
-is_integer p R => too_old_compiler
-is_float p R => too_old_compiler
-is_atom p R => too_old_compiler
-
-is_eq_exact p S1 S2 => too_old_compiler
+too_old_compiler | never() =>
# In R9C and earlier, the loader used to insert special instructions inside
# the module_info/0,1 functions. (In R10B and later, the compiler inserts
@@ -88,9 +70,6 @@ i_time_breakpoint
i_return_time_trace
i_return_to_trace
i_yield
-i_global_cons
-i_global_tuple
-i_global_copy
return
@@ -310,8 +289,6 @@ raise s s
badarg j
system_limit j
-move R R =>
-
move C=cxy r | jump Lbl => move_jump Lbl C
%macro: move_jump MoveJump -nonext
@@ -618,8 +595,6 @@ get_tuple_element Reg P Dst => i_get_tuple_element Reg P Dst | original_reg Reg
original_reg Reg Pos =>
-get_tuple_element Reg P Dst => i_get_tuple_element Reg P Dst
-
original_reg/2
extract_next_element D1=xy | original_reg Reg P1 | get_tuple_element Reg P2 D2=xy | \
@@ -908,23 +883,6 @@ call_ext_last u==3 u$func:erlang:hibernate/3 D => i_hibernate
call_ext_only u==3 u$func:erlang:hibernate/3 => i_hibernate
#
-# Hybrid memory architecture need special cons and tuple instructions
-# that allocate on the message area. These looks like BIFs in the BEAM code.
-#
-
-call_ext u==2 u$func:hybrid:cons/2 => i_global_cons
-call_ext_last u==2 u$func:hybrid:cons/2 D => i_global_cons | deallocate_return D
-call_ext_only Ar=u==2 u$func:hybrid:cons/2 => i_global_cons | return
-
-call_ext u==1 u$func:hybrid:tuple/1 => i_global_tuple
-call_ext_last u==1 u$func:hybrid:tuple/1 D => i_global_tuple | deallocate_return D
-call_ext_only Ar=u==1 u$func:hybrid:tuple/1 => i_global_tuple | return
-
-call_ext u==1 u$func:hybrid:copy/1 => i_global_copy
-call_ext_last u==1 u$func:hybrid:copy/1 D => i_global_copy | deallocate_return D
-call_ext_only u==1 Ar=u$func:hybrid:copy/1 => i_global_copy | return
-
-#
# The general case for BIFs that have no special instructions.
# A BIF used in the tail must be followed by a return instruction.
#
@@ -961,9 +919,9 @@ move S=c r | call_ext Ar=u Func=u$is_not_bif => i_move_call_ext S r Func
move S=c r | call_ext_last Ar=u Func=u$is_not_bif D => i_move_call_ext_last Func D S r
move S=c r | call_ext_only Ar=u Func=u$is_not_bif => i_move_call_ext_only Func S r
-call_ext Ar=u Func => i_call_ext Func
-call_ext_last Ar=u Func D => i_call_ext_last Func D
-call_ext_only Ar=u Func => i_call_ext_only Func
+call_ext Ar Func => i_call_ext Func
+call_ext_last Ar Func D => i_call_ext_last Func D
+call_ext_only Ar Func => i_call_ext_only Func
i_apply
i_apply_last P
@@ -997,7 +955,7 @@ bif1 p Bif S1 Dst => bif1_body Bif S1 Dst
bif1_body Bif Literal=q Dst => move Literal x | bif1_body Bif x Dst
bif2 p Bif S1 S2 Dst => i_fetch S1 S2 | i_bif2_body Bif Dst
-bif2 Fail=f Bif S1 S2 Dst => i_fetch S1 S2 | i_bif2 Fail Bif Dst
+bif2 Fail Bif S1 S2 Dst => i_fetch S1 S2 | i_bif2 Fail Bif Dst
i_get s d
@@ -1080,8 +1038,8 @@ i_move_call_ext_only e c r
# Fun calls.
-call_fun Arity=u | deallocate D | return => i_call_fun_last Arity D
-call_fun Arity=u => i_call_fun Arity
+call_fun Arity | deallocate D | return => i_call_fun_last Arity D
+call_fun Arity => i_call_fun Arity
i_call_fun I
i_call_fun_last I P
@@ -1337,13 +1295,13 @@ i_bs_utf16_size s d
bs_put_utf8 Fail=j Flags=u Literal=q => \
move Literal x | bs_put_utf8 Fail Flags x
-bs_put_utf8 Fail=j u Src=s => i_bs_put_utf8 Fail Src
+bs_put_utf8 Fail u Src=s => i_bs_put_utf8 Fail Src
i_bs_put_utf8 j s
bs_put_utf16 Fail=j Flags=u Literal=q => \
move Literal x | bs_put_utf16 Fail Flags x
-bs_put_utf16 Fail=j Flags=u Src=s => i_bs_put_utf16 Fail Flags Src
+bs_put_utf16 Fail Flags=u Src=s => i_bs_put_utf16 Fail Flags Src
i_bs_put_utf16 j I s
@@ -1508,34 +1466,13 @@ bif1 Fail u$bif:erlang:trunc/1 s d => too_old_compiler
#
# Guard BIFs.
#
-gc_bif1 Fail I Bif=u$bif:erlang:length/1 Src Dst=d => \
- gen_guard_bif1(Fail, I, Bif, Src, Dst)
-
-gc_bif1 Fail I Bif=u$bif:erlang:size/1 Src Dst=d => \
+gc_bif1 Fail I Bif Src Dst => \
gen_guard_bif1(Fail, I, Bif, Src, Dst)
-gc_bif1 Fail I Bif=u$bif:erlang:bit_size/1 Src Dst=d => \
- gen_guard_bif1(Fail, I, Bif, Src, Dst)
-
-gc_bif1 Fail I Bif=u$bif:erlang:byte_size/1 Src Dst=d => \
- gen_guard_bif1(Fail, I, Bif, Src, Dst)
-
-gc_bif1 Fail I Bif=u$bif:erlang:abs/1 Src Dst=d => \
- gen_guard_bif1(Fail, I, Bif, Src, Dst)
-
-gc_bif1 Fail I Bif=u$bif:erlang:float/1 Src Dst=d => \
- gen_guard_bif1(Fail, I, Bif, Src, Dst)
-
-gc_bif1 Fail I Bif=u$bif:erlang:round/1 Src Dst=d => \
- gen_guard_bif1(Fail, I, Bif, Src, Dst)
-
-gc_bif1 Fail I Bif=u$bif:erlang:trunc/1 Src Dst=d => \
- gen_guard_bif1(Fail, I, Bif, Src, Dst)
-
-gc_bif2 Fail I Bif=u$bif:erlang:binary_part/2 S1 S2 Dst=d => \
+gc_bif2 Fail I Bif S1 S2 Dst => \
gen_guard_bif2(Fail, I, Bif, S1, S2, Dst)
-gc_bif3 Fail I Bif=u$bif:erlang:binary_part/3 S1 S2 S3 Dst=d => \
+gc_bif3 Fail I Bif S1 S2 S3 Dst => \
gen_guard_bif3(Fail, I, Bif, S1, S2, S3, Dst)
i_gc_bif1 Fail Bif V=q Live D => move V x | i_gc_bif1 Fail Bif x Live D
@@ -1553,6 +1490,15 @@ ii_gc_bif3/7
ii_gc_bif3 Fail Bif S1 S2 S3 Live D => move S1 x | i_fetch S2 S3 | i_gc_bif3 Fail Bif x Live D
i_gc_bif3 j I s I d
+
+#
+# The following instruction is specially handled in beam_load.c
+# to produce a user-friendly message if an unsupported guard BIF is
+# encountered.
+#
+unsupported_guard_bif/3
+unsupported_guard_bif A B C | never() =>
+
#
# R13B03
#
diff --git a/erts/emulator/utils/beam_makeops b/erts/emulator/utils/beam_makeops
index ebf7db3277..58c36c3bdc 100755
--- a/erts/emulator/utils/beam_makeops
+++ b/erts/emulator/utils/beam_makeops
@@ -105,7 +105,9 @@ 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.
@@ -187,6 +189,12 @@ sub define_type_bit {
}
#
+# Pre-define the 'fail' instruction. It is used internally
+# by the 'try_me_else_fail' instruction.
+#
+$match_engine_ops{'TOP_fail'} = 1;
+
+#
# Sanity checks.
#
@@ -1304,7 +1312,8 @@ sub tr_gen {
foreach $ref (@g) {
my($line, $orig_transform, $from_ref, $to_ref) = @$ref;
- my $so_far = tr_gen_from($line, @$from_ref);
+ my $used_ref = used_vars($from_ref, $to_ref);
+ my $so_far = tr_gen_from($line, $used_ref, @$from_ref);
tr_gen_to($line, $orig_transform, $so_far, @$to_ref);
}
@@ -1313,9 +1322,22 @@ sub tr_gen {
#
my($offset) = 0;
print "Uint op_transform[] = {\n";
- foreach $key (keys %gen_transform) {
+ foreach $key (sort keys %gen_transform) {
$gen_transform_offset{$key} = $offset;
- foreach $instr (@{$gen_transform{$key}}) {
+ my @instr = @{$gen_transform{$key}};
+
+ #
+ # If the last instruction is 'fail', remove it and
+ # convert the previous 'try_me_else' to 'try_me_else_fail'.
+ #
+ if (is_instr($instr[$#instr], 'fail')) {
+ pop(@instr);
+ my $i = $#instr;
+ $i-- while !is_instr($instr[$i], 'try_me_else');
+ $instr[$i] = make_op('', 'try_me_else_fail');
+ }
+
+ foreach $instr (@instr) {
my($size, $instr_ref, $comment) = @$instr;
my($op, @args) = @$instr_ref;
print " ";
@@ -1342,8 +1364,48 @@ sub tr_gen {
print "};\n\n";
}
+sub used_vars {
+ my($from_ref,$to_ref) = @_;
+ my %used;
+ my %seen;
+
+ foreach my $ref (@$from_ref) {
+ my($name,$arity,@ops) = @$ref;
+ if ($name =~ /^[.]/) {
+ foreach my $var (@ops) {
+ $used{$var} = 1;
+ }
+ } else {
+ # Any variable that is used at least twice on the
+ # left-hand side is used. (E.g. "move R R".)
+ foreach my $op (@ops) {
+ my($var, $type, $type_val) = @$op;
+ next if $var eq '';
+ $used{$var} = 1 if $seen{$var};
+ $seen{$var} = 1;
+ }
+ }
+ }
+
+ foreach my $ref (@$to_ref) {
+ my($name, $arity, @ops) = @$ref;
+ if ($name =~ /^[.]/) {
+ foreach my $var (@ops) {
+ $used{$var} = 1;
+ }
+ } else {
+ foreach my $op (@ops) {
+ my($var, $type, $type_val) = @$op;
+ next if $var eq '';
+ $used{$var} = 1;
+ }
+ }
+ }
+ \%used;
+}
+
sub tr_gen_from {
- my($line, @tr) = @_;
+ my($line,$used_ref,@tr) = @_;
my(%var) = ();
my(%var_type);
my($var_num) = 0;
@@ -1353,25 +1415,30 @@ sub tr_gen_from {
my(@fix_pred_funcs);
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);
- my $next_instr = pop(@code); # Get rid of 'next_instr'
push(@fix_pred_funcs, scalar(@code));
push(@code, [$name, @ops]);
- push(@code, $next_instr);
next;
}
@@ -1383,17 +1450,21 @@ sub tr_gen_from {
unless defined $gen_opnum{$name,$arity};
$opnum = $gen_opnum{$name,$arity};
- push(@code, &make_op("$name/$arity", 'is_op', $opnum));
+ push(@code, make_op("$name/$arity", 'next_instr', $opnum));
$min_window++;
foreach $op (@ops) {
my($var, $type, $type_val, $cond, $val) = @$op;
+ 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
# 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') {
@@ -1407,7 +1478,7 @@ sub tr_gen_from {
push(@code, &make_op($types, 'is_type', $type_mask));
} else {
$cond = '';
- push(@code, &make_op($types, 'is_type_eq',
+ push(@code, &make_op("$types== $val", 'is_type_eq',
$type_mask, $val));
}
}
@@ -1415,46 +1486,55 @@ 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 '*') {
#
# Reserve a hole for a 'rest_args' instruction.
#
+ $ignored_var = '';
push(@fix_rest_args, scalar(@code));
push(@code, $var);
- } else {
+ } elsif ($var_used{$var}) {
+ $ignored_var = '';
$var_type{$var} = 'scalar';
$var{$var} = $var_num;
$var_num++;
push(@code, &make_op($var, 'set_var', $var{$var}));
}
}
- if (is_set_var_instr($code[$#code])) {
+ if (is_instr($code[$#code], 'set_var')) {
my $ref = pop @code;
my $comment = $ref->[2];
my $var = $ref->[1][1];
push(@code, make_op($comment, 'set_var_next_arg', $var));
} else {
- push(@code, &make_op('', 'next_arg'));
+ push(@code, &make_op($ignored_var, 'next_arg'));
}
}
- push(@code, &make_op('', 'next_instr'));
- pop(@code) if $code[$#code]->[1][0] eq 'next_arg';
+
+ # Remove redundant 'next_arg' instructions before the end
+ # of the instruction.
+ pop(@code) while is_instr($code[$#code], 'next_arg');
}
#
# 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
@@ -1484,9 +1564,8 @@ sub tr_gen_from {
push(@args, "var+$var{$var}");
}
}
- splice(@code, $index, 1, &make_op("$name()",
- 'pred', scalar(@pred_table)));
- push(@pred_table, [$name, @args]);
+ my $pi = tr_next_index(\@pred_table, \%pred_table, $name, @args);
+ splice(@code, $index, 1, make_op("$name()", 'pred', $pi));
}
$te_max_vars = $var_num
@@ -1503,6 +1582,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;
@@ -1524,9 +1607,10 @@ sub tr_gen_to {
push(@args, "var+$var{$var}");
}
}
- pop(@code); # Get rid of 'next_instr'
- push(@code, &make_op("$name()", 'call', scalar(@call_table)));
- push(@call_table, [$name, @args]);
+ pop(@code); # Get rid of 'commit' instruction
+ my $index = tr_next_index(\@call_table, \%call_table,
+ $name, @args);
+ push(@code, make_op("$name()", 'call_end', $index));
last;
}
@@ -1543,27 +1627,27 @@ sub tr_gen_to {
# Create code to build the generic instruction.
#
- push(@code, &make_op('', 'new_instr'));
- push(@code, &make_op("$name/$arity", 'store_op', $opnum, $arity));
+ push(@code, make_op("$name/$arity", 'new_instr', $opnum));
foreach $op (@ops) {
my($var, $type, $type_val) = @$op;
if ($var ne '') {
&error($where, "variable '$var' unbound")
unless defined $var{$var};
- push(@code, &make_op($var, 'store_var', $var{$var}));
+ push(@code, &make_op($var, 'store_var_next_arg', $var{$var}));
} elsif ($type ne '') {
push(@code, &make_op('', 'store_type', "TAG_$type"));
if ($type_val) {
push(@code, &make_op('', 'store_val', $type_val));
}
+ push(@code, make_op('', 'next_arg'));
}
- push(@code, &make_op('', 'next_arg'));
}
- pop(@code) if $code[$#code]->[1][0] eq 'next_arg';
+ pop(@code) if is_instr($code[$#code], 'next_arg');
}
- push(@code, &make_op('', 'end'));
+ push(@code, make_op('', 'end'))
+ unless is_instr($code[$#code], 'call_end');
#
# Chain together all codes segments having the same first operation.
@@ -1575,11 +1659,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('', '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 {
@@ -1597,21 +1690,38 @@ sub make_op {
[scalar(@op), [@op], $comment];
}
-sub is_set_var_instr {
- my($ref) = @_;
+sub is_instr {
+ my($ref,$op) = @_;
return 0 unless ref($ref) eq 'ARRAY';
- $ref->[1][0] eq 'set_var';
+ $ref->[1][0] eq $op;
+}
+
+sub get_comment {
+ my($ref,$op) = @_;
+ return '' unless ref($ref) eq 'ARRAY';
+ $ref->[2];
+}
+
+sub tr_next_index {
+ my($lref,$href,$name,@args) = @_;
+ my $code = "RVAL = $name(" . join(', ', 'st', @args) . "); break;\n";
+ my $index;
+
+ if (defined $$href{$code}) {
+ $index = $$href{$code};
+ } else {
+ $index = scalar(@$lref);
+ push(@$lref, $code);
+ $$href{$code} = $index;
+ }
+ $index;
}
sub tr_gen_call {
my(@call_table) = @_;
my($i);
- print "\n";
for ($i = 0; $i < @call_table; $i++) {
- my $ref = $call_table[$i];
- my($name, @args) = @$ref;
- print "case $i: RVAL = $name(", join(', ', 'st', @args), "); break;\n";
+ print "case $i: $call_table[$i]";
}
- print "\n";
}