erts: Fix rare case of faulty heap fragment deallocation

after major GC.

Can only be caused by distributed messages containing large maps.
Bad map hashing will increase the risk.

2 files changed, 124 insertions, 8 deletions

diff --git a/erts/emulator/beam/erl_gc.c b/erts/emulator/beam/erl_gc.c
index d2604f1595..2f21111a2e 100644
--- a/erts/emulator/beam/erl_gc.c
+++ b/erts/emulator/beam/erl_gc.c
@@ -1237,6 +1237,7 @@ major_collection(Process* p, int need, Eterm* objv, int nobj, Uint *recl)
     Uint oh_size = (char *) OLD_HTOP(p) - oh;
     Uint n;
     Uint new_sz;
+    int done;
 
     /*
      * Do a fullsweep GC. First figure out the size of the heap
@@ -1440,6 +1441,8 @@ major_collection(Process* p, int need, Eterm* objv, int nobj, Uint *recl)
 
     *recl += size_before - (HEAP_TOP(p) - HEAP_START(p));
 
+    remove_message_buffers(p);
+
     {
 	ErlMessage *msgp;
 
@@ -1458,15 +1461,21 @@ major_collection(Process* p, int need, Eterm* objv, int nobj, Uint *recl)
 	}
     }
 
-    adjust_after_fullsweep(p, need, objv, nobj);
-
-#ifdef HARDDEBUG
-    disallow_heap_frag_ref_in_heap(p);
-#endif
-    remove_message_buffers(p);
+    if (MBUF(p)) {
+        /* This is a very rare case when distributed messages copied above
+         * contained maps so big they did not fit on the heap causing the
+         * factory to create heap frags.
+         * Solution: Trigger a minor gc (without tenuring)
+         */
+        HIGH_WATER(p) = HEAP_START(p);
+        done = 0;
+    } else {
+        adjust_after_fullsweep(p, need, objv, nobj);
+        done = 1;
+    }
 
     ErtsGcQuickSanityCheck(p);
-    return 1;			/* We are done. */
+    return done;
 }
 
 static void
@@ -1955,7 +1964,18 @@ collect_heap_frags(Process* p, Eterm* n_hstart, Eterm* n_htop,
     if (p->dictionary != NULL) {
 	disallow_heap_frag_ref(p, n_htop, p->dictionary->data, p->dictionary->used);
     }
-    disallow_heap_frag_ref_in_heap(p);
+    /* OTP-18: Actually we do allow references from heap to heap fragments now.
+       This can happen when doing "binary_to_term" with a "fat" map contained
+       in another term. A "fat" map is a hashmap with higher heap demand than
+       first estimated by "binary_to_term" causing the factory to allocate
+       additional heap (fragments) for the hashmap tree nodes.
+       Run map_SUITE:t_gc_rare_map_overflow to provoke this.
+
+       Inverted references like this does not matter however. The copy done
+       below by move_one_area() with move markers in the fragments and the
+       sweeping done later by the GC should make everything ok in the end.
+    */
+    /***disallow_heap_frag_ref_in_heap(p);***/
 #endif
 
     /*
diff --git a/erts/emulator/test/map_SUITE.erl b/erts/emulator/test/map_SUITE.erl
index 886ae7d516..1b9758c23e 100644
--- a/erts/emulator/test/map_SUITE.erl
+++ b/erts/emulator/test/map_SUITE.erl
@@ -58,6 +58,7 @@
 	%% erlang
 	t_erlang_hash/1,
 	t_map_encode_decode/1,
+	t_gc_rare_map_overflow/1,
 
 	%% non specific BIF related
 	t_bif_build_and_check/1,
@@ -121,6 +122,7 @@ all() -> [
 
 	%% erlang
 	t_erlang_hash, t_map_encode_decode,
+	t_gc_rare_map_overflow,
 	t_map_size, t_is_map,
 
 	%% non specific BIF related
@@ -2966,3 +2968,97 @@ do_badmap_17(Config) ->
 
 %% Use this function to avoid compile-time evaluation of an expression.
 id(I) -> I.
+
+
+%% OTP-13146
+%% Provoke major GC with a lot of "fat" maps on external format in msg queue
+%% causing heap fragments to be allocated.
+t_gc_rare_map_overflow(Config) ->
+    Pa = filename:dirname(code:which(?MODULE)),
+    {ok, Node} = test_server:start_node(gc_rare_map_overflow, slave, [{args, "-pa \""++Pa++"\""}]),
+    Echo = spawn_link(Node, fun Loop() -> receive {From,Msg} -> From ! Msg
+					  end,
+					  Loop()
+			    end),
+    FatMap = fatmap(34),
+    false = (flatmap =:= erts_internal:map_type(FatMap)),
+
+    t_gc_rare_map_overflow_do(Echo, FatMap, fun() -> erlang:garbage_collect() end),
+
+    % Repeat test for minor gc:
+    minor_collect(), % need this to make the next gc really be a minor
+    t_gc_rare_map_overflow_do(Echo, FatMap, fun() -> true = minor_collect() end),
+
+    unlink(Echo),
+    test_server:stop_node(Node).
+
+t_gc_rare_map_overflow_do(Echo, FatMap, GcFun) ->
+    Master = self(),
+    true = receive M -> false after 0 -> true end,   % assert empty msg queue
+    Echo ! {Master, token},
+    repeat(1000, fun(_) -> Echo ! {Master, FatMap} end, void),
+
+    timer:sleep(100),                % Wait for maps to arrive in our msg queue
+    token = receive Tok -> Tok end,  % and provoke move from outer to inner msg queue
+
+    %% Do GC that will "overflow" and create heap frags due to all the fat maps
+    GcFun(),
+
+    %% Now check that all maps in msg queueu are intact
+    %% Will crash emulator in OTP-18.1
+    repeat(1000, fun(_) -> FatMap = receive FM -> FM end end, void),
+    ok.
+
+minor_collect() ->
+    minor_collect(minor_gcs()).
+
+minor_collect(Before) ->
+    After = minor_gcs(),
+    case After of
+	_ when After > Before -> true;
+	_ when After =:= Before -> minor_collect(Before);
+	0 -> false
+    end.
+
+minor_gcs() ->
+    {garbage_collection, Info} = process_info(self(), garbage_collection),
+    {minor_gcs, GCS} = lists:keyfind(minor_gcs, 1, Info),
+    GCS.
+
+%% Generate a map with N (or N+1) keys that has an abnormal heap demand.
+%% Done by finding keys that collide in the first 32-bit hash.
+fatmap(N) ->
+    erts_debug:set_internal_state(available_internal_state, true),
+    Table = ets:new(void, [bag, private]),
+
+    Seed0 = rand:seed_s(exsplus, {4711, 3141592, 2718281}),
+    Seed1 = fatmap_populate(Table, Seed0, (1 bsl 16)),
+    Keys = fatmap_generate(Table, Seed1, N, []),
+    ets:delete(Table),
+    maps:from_list([{K,K} || K <- Keys]).
+
+fatmap_populate(_, Seed, 0) -> Seed;
+fatmap_populate(Table, Seed, N) ->
+    {I, NextSeed} = rand:uniform_s(1 bsl 48, Seed),
+    Hash = internal_hash(I),
+    ets:insert(Table, [{Hash, I}]),
+    fatmap_populate(Table, NextSeed, N-1).
+
+
+fatmap_generate(_, _, N, Acc) when N =< 0 ->
+    Acc;
+fatmap_generate(Table, Seed, N0, Acc0) ->    
+    {I, NextSeed} = rand:uniform_s(1 bsl 48, Seed),
+    Hash = internal_hash(I),
+    case ets:member(Table, Hash) of
+	true ->
+	    NewKeys = [I | ets:lookup_element(Table, Hash, 2)],
+	    Acc1 = lists:usort(Acc0 ++ NewKeys),
+	    N1 = N0 - (length(Acc1) - length(Acc0)),
+	    fatmap_generate(Table, NextSeed, N1, Acc1);
+	false ->
+	    fatmap_generate(Table, NextSeed, N0, Acc0)
+    end.
+
+internal_hash(Term) ->
+    erts_debug:get_internal_state({internal_hash, Term}).