HiPE: Verify GC safety of derived values

HiPE has had metadata for gc safety on it's temporaries for a while, but
it has never been enforced or even checked, so naturally several
gc-safety violations has slipped through.

A new pass, hipe_rtl_verify_gcsafe verifies gcsafety on optimised RTL
and is used when running the testsuite, and can be manually enabled with
+{hipe,[verify_gcsafe]}.

6 files changed, 103 insertions, 10 deletions

diff --git a/lib/hipe/rtl/Makefile b/lib/hipe/rtl/Makefile
index 5abc9ec049..becdd0b7d8 100644
--- a/lib/hipe/rtl/Makefile
+++ b/lib/hipe/rtl/Makefile
@@ -50,7 +50,7 @@ HIPE_MODULES = hipe_rtl hipe_rtl_cfg \
 	  hipe_rtl_ssa hipe_rtl_ssa_const_prop \
 	  hipe_rtl_cleanup_const hipe_rtl_symbolic hipe_rtl_lcm \
 	  hipe_rtl_ssapre hipe_rtl_binary hipe_rtl_ssa_avail_expr \
-	  hipe_rtl_arch hipe_tagscheme
+	  hipe_rtl_arch hipe_tagscheme hipe_rtl_verify_gcsafe
 else
 HIPE_MODULES =
 endif
diff --git a/lib/hipe/rtl/hipe_rtl.erl b/lib/hipe/rtl/hipe_rtl.erl
index 04c9728d5c..33027f3259 100644
--- a/lib/hipe/rtl/hipe_rtl.erl
+++ b/lib/hipe/rtl/hipe_rtl.erl
@@ -1740,7 +1740,10 @@ pp_reg(Dev, Arg) ->
     true ->
       pp_hard_reg(Dev, reg_index(Arg));
     false ->
-      io:format(Dev, "r~w", [reg_index(Arg)])
+      case reg_is_gcsafe(Arg) of
+        true -> io:format(Dev, "rs~w", [reg_index(Arg)]);
+        false -> io:format(Dev, "r~w", [reg_index(Arg)])
+      end
   end.
 
 pp_var(Dev, Arg) ->
diff --git a/lib/hipe/rtl/hipe_rtl_binary_construct.erl b/lib/hipe/rtl/hipe_rtl_binary_construct.erl
index bc29e1d081..f8b4446745 100644
--- a/lib/hipe/rtl/hipe_rtl_binary_construct.erl
+++ b/lib/hipe/rtl/hipe_rtl_binary_construct.erl
@@ -359,7 +359,8 @@ not_writable_code(Bin, SizeReg, Dst, Base, Offset, Unit,
 allocate_writable(Dst, Base, UsedBytes, TotBytes, TotSize) ->
   Zero = hipe_rtl:mk_imm(0),
   [NextLbl] = create_lbls(1),
-  [EndSubSize, EndSubBitSize, ProcBin] = create_regs(3),
+  [EndSubSize, EndSubBitSize] = create_regs(2),
+  [ProcBin] = create_unsafe_regs(1),
   [hipe_rtl:mk_call([Base], bs_allocate, [UsedBytes],
 		    hipe_rtl:label_name(NextLbl), [], not_remote),
    NextLbl,
@@ -586,12 +587,12 @@ const_init2(Size, Dst, Base, Offset, TrueLblName) ->
     false ->
       ByteSize = hipe_rtl:mk_new_reg(),
       [hipe_rtl:mk_gctest(?PROC_BIN_WORDSIZE+?SUB_BIN_WORDSIZE),
-       hipe_rtl:mk_move(Offset, hipe_rtl:mk_imm(0)),
        hipe_rtl:mk_move(ByteSize, hipe_rtl:mk_imm(Size)),
        hipe_rtl:mk_call([Base], bs_allocate, [ByteSize],
 			hipe_rtl:label_name(NextLbl), [], not_remote),
        NextLbl,
        hipe_tagscheme:create_refc_binary(Base, ByteSize, Dst),
+       hipe_rtl:mk_move(Offset, hipe_rtl:mk_imm(0)),
        hipe_rtl:mk_goto(TrueLblName)]
   end.
 
@@ -634,13 +635,12 @@ var_init2(Size, Dst, Base, Offset, TrueLblName, SystemLimitLblName, FalseLblName
   Log2WordSize = hipe_rtl_arch:log2_word_size(),
   WordSize = hipe_rtl_arch:word_size(),
   [ContLbl, HeapLbl, REFCLbl, NextLbl] = create_lbls(4),
-  [USize, Tmp] = create_unsafe_regs(2),
+  [USize, Tmp] = create_regs(2),
   [get_word_integer(Size, USize, SystemLimitLblName, FalseLblName),
    hipe_rtl:mk_branch(USize, leu, hipe_rtl:mk_imm(?MAX_BINSIZE),
 		      hipe_rtl:label_name(ContLbl),
 		      SystemLimitLblName),
    ContLbl,
-   hipe_rtl:mk_move(Offset, hipe_rtl:mk_imm(0)),
    hipe_rtl:mk_branch(USize, leu, hipe_rtl:mk_imm(?MAX_HEAP_BIN_SIZE),
 		      hipe_rtl:label_name(HeapLbl),
 		      hipe_rtl:label_name(REFCLbl)),
@@ -650,6 +650,7 @@ var_init2(Size, Dst, Base, Offset, TrueLblName, SystemLimitLblName, FalseLblName
    hipe_rtl:mk_alu(Tmp, Tmp, add, hipe_rtl:mk_imm(?SUB_BIN_WORDSIZE)),
    hipe_rtl:mk_gctest(Tmp),
    hipe_tagscheme:create_heap_binary(Base, USize, Dst),
+   hipe_rtl:mk_move(Offset, hipe_rtl:mk_imm(0)),
    hipe_rtl:mk_goto(TrueLblName),
    REFCLbl,
    hipe_rtl:mk_gctest(?PROC_BIN_WORDSIZE+?SUB_BIN_WORDSIZE),
@@ -657,6 +658,7 @@ var_init2(Size, Dst, Base, Offset, TrueLblName, SystemLimitLblName, FalseLblName
 		    hipe_rtl:label_name(NextLbl), [], not_remote),
    NextLbl,
    hipe_tagscheme:create_refc_binary(Base, USize, Dst),
+   hipe_rtl:mk_move(Offset, hipe_rtl:mk_imm(0)),
    hipe_rtl:mk_goto(TrueLblName)].
 
 var_init_bits(Size, Dst, Base, Offset, TrueLblName, SystemLimitLblName, FalseLblName) ->
diff --git a/lib/hipe/rtl/hipe_rtl_binary_match.erl b/lib/hipe/rtl/hipe_rtl_binary_match.erl
index 362a52f8fe..83699a60f8 100644
--- a/lib/hipe/rtl/hipe_rtl_binary_match.erl
+++ b/lib/hipe/rtl/hipe_rtl_binary_match.erl
@@ -842,12 +842,12 @@ make_dyn_prep(SizeReg, CCode) ->
 %%------------------------------------------------------------------------
 
 get_unaligned_int(Dst1, Size, Base, Offset, Shiftr, Type, TrueLblName) ->
-  [Reg] = create_regs(1),
+  [Reg] = create_gcsafe_regs(1),
   [get_maybe_unaligned_int_to_reg(Reg, Size, Base, Offset, Shiftr, Type),
    do_bignum_code(Size, Type, Reg, Dst1, TrueLblName)].
 
 get_maybe_unaligned_int_to_reg(Reg, Size, Base, Offset, Shiftr, Type) ->
-  [LowBits] = create_regs(1),
+  [LowBits] = create_gcsafe_regs(1),
   [AlignedLbl, UnAlignedLbl, EndLbl] = create_lbls(3),
   [hipe_rtl:mk_alub(LowBits, Offset, 'and', hipe_rtl:mk_imm(?LOW_BITS),
 		    eq, hipe_rtl:label_name(AlignedLbl), 
@@ -1001,7 +1001,7 @@ do_bignum_code(Size, {Signedness,_}, Src, Dst1, TrueLblName)
     end.
 
 signed_bignum(Dst1, Src, TrueLblName) ->
-  Tmp1 = hipe_rtl:mk_new_reg(),
+  Tmp1 = hipe_rtl:mk_new_reg_gcsafe(),
   BignumLabel = hipe_rtl:mk_new_label(),
   [hipe_tagscheme:realtag_fixnum(Dst1, Src),
    hipe_tagscheme:realuntag_fixnum(Tmp1, Dst1),
diff --git a/lib/hipe/rtl/hipe_rtl_varmap.erl b/lib/hipe/rtl/hipe_rtl_varmap.erl
index 375a8f85c0..f34c66ab85 100644
--- a/lib/hipe/rtl/hipe_rtl_varmap.erl
+++ b/lib/hipe/rtl/hipe_rtl_varmap.erl
@@ -105,7 +105,7 @@ icode_var2rtl_var(Var, Map) ->
 	{reg, IsGcSafe} ->
 	  NewVar =
 	    case IsGcSafe of
-	      %% true -> hipe_rtl:mk_new_reg_gcsafe();
+              true -> hipe_rtl:mk_new_reg_gcsafe();
 	      false -> hipe_rtl:mk_new_reg()
 	    end,
 	  {NewVar, insert(Var, NewVar, Map)}
diff --git a/lib/hipe/rtl/hipe_rtl_verify_gcsafe.erl b/lib/hipe/rtl/hipe_rtl_verify_gcsafe.erl
new file mode 100644
index 0000000000..c3f20bfec1
--- /dev/null
+++ b/lib/hipe/rtl/hipe_rtl_verify_gcsafe.erl
@@ -0,0 +1,88 @@
+%% -*- mode: erlang; erlang-indent-level: 2 -*-
+%%
+%% 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.
+%%
+-module(hipe_rtl_verify_gcsafe).
+
+-export([check/1]).
+
+-include("../flow/cfg.hrl").              %% needed for the specs
+-include("hipe_rtl.hrl").
+
+check(CFG) ->
+  Liveness = hipe_rtl_liveness:analyze(CFG),
+  put({?MODULE, 'fun'}, CFG#cfg.info#cfg_info.'fun'),
+  lists:foreach(
+    fun(Lb) ->
+        put({?MODULE, label}, Lb),
+        Liveout = hipe_rtl_liveness:liveout(Liveness, Lb),
+        BB = hipe_rtl_cfg:bb(CFG, Lb),
+        check_instrs(lists:reverse(hipe_bb:code(BB)), Liveout)
+    end, hipe_rtl_cfg:labels(CFG)),
+  erase({?MODULE, 'fun'}),
+  erase({?MODULE, label}),
+  erase({?MODULE, instr}),
+  ok.
+
+check_instrs([], _Livein) -> ok;
+check_instrs([I|Is], LiveOut) ->
+  Def = ordsets:from_list(hipe_rtl:defines(I)),
+  Use = ordsets:from_list(hipe_rtl:uses(I)),
+  LiveOver = ordsets:subtract(LiveOut, Def),
+  LiveIn = ordsets:union(LiveOver, Use),
+  case (hipe_rtl:is_call(I)
+        andalso not safe_primop(hipe_rtl:call_fun(I)))
+    orelse is_record(I, gctest)
+  of
+    false -> ok;
+    true ->
+      put({?MODULE, instr}, I),
+      lists:foreach(fun verify_live/1, LiveOver)
+  end,
+  check_instrs(Is, LiveIn).
+
+verify_live(T) ->
+  case hipe_rtl:is_reg(T) of
+    false -> ok;
+    true ->
+      case hipe_rtl:reg_is_gcsafe(T) of
+        true -> ok;
+        false ->
+          error({gcunsafe_live_over_call,
+                 get({?MODULE, 'fun'}),
+                 {label, get({?MODULE, label})},
+                 get({?MODULE, instr}),
+                 T})
+      end
+  end.
+
+%% Primops that can't gc
+%% Note: This information is essentially duplicated from hipe_bif_list.m4
+safe_primop(is_divisible) -> true;
+safe_primop(is_unicode) -> true;
+safe_primop(cmp_2) -> true;
+safe_primop(eq_2) -> true;
+safe_primop(bs_allocate) -> true;
+safe_primop(bs_reallocate) -> true;
+safe_primop(bs_utf8_size) -> true;
+safe_primop(bs_get_utf8) -> true;
+safe_primop(bs_utf16_size) -> true;
+safe_primop(bs_get_utf16) -> true;
+safe_primop(bs_validate_unicode_retract) -> true;
+safe_primop(bs_put_small_float) -> true;
+safe_primop(bs_put_bits) -> true;
+safe_primop(emasculate_binary) -> true;
+safe_primop(atomic_inc) -> true;
+%% Not noproc but manually verified
+safe_primop(bs_put_big_integer) -> true;
+safe_primop(_) -> false.