[commit: ghc] ghc-8.4: rts: Fix compaction of SmallMutArrPtrs (0d40fd7)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.4
Link       : http://ghc.haskell.org/trac/ghc/changeset/0d40fd758de02ef9898883f611102288eac18c51/ghc

>---------------------------------------------------------------

commit 0d40fd758de02ef9898883f611102288eac18c51
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Sat May 19 14:00:59 2018 -0400

    rts: Fix compaction of SmallMutArrPtrs
    
    This was blatantly wrong due to copy-paste blindness:
    
     * labels were shadowed, which GHC doesn't warn about(!), resulting in
       plainly wrong behavior
     * the sharing check was omitted
     * the wrong closure layout was being used
    
    Moreover, the test wasn't being run due to its primitive dependency, so
    I didn't even notice. Sillyness.
    
    Test Plan: install `primitive`, `make test TEST=compact_small_array`
    
    Reviewers: simonmar, erikd
    
    Reviewed By: simonmar
    
    Subscribers: rwbarton, thomie, carter
    
    GHC Trac Issues: #13857.
    
    Differential Revision: https://phabricator.haskell.org/D4702
    
    (cherry picked from commit 12deb9a97c05ad462ef04e8d2062c3d11c52c6ff)


>---------------------------------------------------------------

0d40fd758de02ef9898883f611102288eac18c51
 .../ghc-compact/tests/compact_small_ptr_array.hs   |  2 +-
 .../tests/compact_small_ptr_array.stdout           |  1 +
 rts/Compact.cmm                                    | 28 ++++++++++++----------
 3 files changed, 17 insertions(+), 14 deletions(-)

diff --git a/libraries/ghc-compact/tests/compact_small_ptr_array.hs b/libraries/ghc-compact/tests/compact_small_ptr_array.hs
index 8599c71..77c9fa8 100644
--- a/libraries/ghc-compact/tests/compact_small_ptr_array.hs
+++ b/libraries/ghc-compact/tests/compact_small_ptr_array.hs
@@ -3,6 +3,6 @@ import Data.Primitive.SmallArray
 
 main :: IO ()
 main = do
-    arr <- newSmallArray 5 (Just 'a')
+    arr <- newSmallArray 5 (Just 'a') >>= unsafeFreezeSmallArray
     arr' <- compact arr
     print $ getCompact arr'
diff --git a/libraries/ghc-compact/tests/compact_small_ptr_array.stdout b/libraries/ghc-compact/tests/compact_small_ptr_array.stdout
new file mode 100644
index 0000000..24b514e
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_small_ptr_array.stdout
@@ -0,0 +1 @@
+fromListN 5 [Just 'a',Just 'a',Just 'a',Just 'a',Just 'a']
diff --git a/rts/Compact.cmm b/rts/Compact.cmm
index 174444d..d1c8ead 100644
--- a/rts/Compact.cmm
+++ b/rts/Compact.cmm
@@ -189,24 +189,26 @@ eval:
         SMALL_MUT_ARR_PTRS_FROZEN0,
         SMALL_MUT_ARR_PTRS_FROZEN: {
 
-        W_ i, size, ptrs;
-        size = SIZEOF_StgMutArrPtrs + WDS(StgMutArrPtrs_size(p));
-        ptrs = StgMutArrPtrs_ptrs(p);
-        ALLOCATE(compact, BYTES_TO_WDS(size), p, to, tag);
+        (should) = ccall shouldCompact(compact "ptr", p "ptr");
+        if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = p; return(); }
+
+        CHECK_HASH();
+
+        W_ i, ptrs;
+        ptrs = StgSmallMutArrPtrs_ptrs(p);
+        ALLOCATE(compact, BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + ptrs, p, to, tag);
         P_[pp] = tag | to;
         SET_HDR(to, StgHeader_info(p), StgHeader_ccs(p));
-        StgMutArrPtrs_ptrs(to) = ptrs;
-        StgMutArrPtrs_size(to) = StgMutArrPtrs_size(p);
-        prim %memcpy(to, p, size, 1);
+        StgSmallMutArrPtrs_ptrs(to) = ptrs;
         i = 0;
-      loop0:
+      loop1:
         if (i < ptrs) {
             W_ q;
             q = to + SIZEOF_StgSmallMutArrPtrs + WDS(i);
             call stg_compactAddWorkerzh(
                 compact, P_[p + SIZEOF_StgSmallMutArrPtrs + WDS(i)], q);
             i = i + 1;
-            goto loop0;
+            goto loop1;
         }
         return();
     }
@@ -238,16 +240,16 @@ eval:
         // First, copy the non-pointers
         if (nptrs > 0) {
             i = ptrs;
-        loop1:
+        loop2:
             StgClosure_payload(to,i) = StgClosure_payload(p,i);
             i = i + 1;
-            if (i < ptrs + nptrs) goto loop1;
+            if (i < ptrs + nptrs) goto loop2;
         }
 
         // Next, recursively compact and copy the pointers
         if (ptrs == 0) { return(); }
         i = 0;
-      loop2:
+      loop3:
         W_ q;
         q = to + SIZEOF_StgHeader + OFFSET_StgClosure_payload + WDS(i);
         // Tail-call the last one.  This means we don't build up a deep
@@ -257,7 +259,7 @@ eval:
         }
         call stg_compactAddWorkerzh(compact, StgClosure_payload(p,i), q);
         i = i + 1;
-        goto loop2;
+        goto loop3;
     }
 
     // these might be static closures that we can avoid copying into