[commit: ghc] ghc-8.2: CNF: Implement compaction for small pointer arrays (6712904)

[git at git.haskell.org]

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

On branch  : ghc-8.2
Link       : http://ghc.haskell.org/trac/ghc/changeset/6712904886070df03887a47448100593c55fc1ff/ghc

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

commit 6712904886070df03887a47448100593c55fc1ff
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Thu Aug 24 21:55:27 2017 -0400

    CNF: Implement compaction for small pointer arrays
    
    Test Plan: Validate
    
    Reviewers: austin, erikd, simonmar, dfeuer
    
    Reviewed By: dfeuer
    
    Subscribers: rwbarton, andrewthad, thomie, dfeuer
    
    GHC Trac Issues: #13860, #13857
    
    Differential Revision: https://phabricator.haskell.org/D3888
    
    (cherry picked from commit 5f3d2d3be034e04ba872f2695ab6d7b75de66663)


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

6712904886070df03887a47448100593c55fc1ff
 libraries/ghc-compact/tests/all.T                  |  1 +
 .../ghc-compact/tests/compact_small_ptr_array.hs   |  8 ++++++++
 rts/Compact.cmm                                    | 24 +++++++++++++++++++---
 3 files changed, 30 insertions(+), 3 deletions(-)

diff --git a/libraries/ghc-compact/tests/all.T b/libraries/ghc-compact/tests/all.T
index 753592e..0264bab 100644
--- a/libraries/ghc-compact/tests/all.T
+++ b/libraries/ghc-compact/tests/all.T
@@ -4,6 +4,7 @@ test('compact_simple', normal, compile_and_run, [''])
 test('compact_loop', normal, compile_and_run, [''])
 test('compact_append', normal, compile_and_run, [''])
 test('compact_autoexpand', normal, compile_and_run, [''])
+test('compact_small_array', [reqlib('primitive')], compile_and_run, [''])
 test('compact_simple_array', normal, compile_and_run, [''])
 test('compact_huge_array', normal, compile_and_run, [''])
 test('compact_serialize', normal, compile_and_run, [''])
diff --git a/libraries/ghc-compact/tests/compact_small_ptr_array.hs b/libraries/ghc-compact/tests/compact_small_ptr_array.hs
new file mode 100644
index 0000000..8599c71
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_small_ptr_array.hs
@@ -0,0 +1,8 @@
+import GHC.Compact
+import Data.Primitive.SmallArray
+
+main :: IO ()
+main = do
+    arr <- newSmallArray 5 (Just 'a')
+    arr' <- compact arr
+    print $ getCompact arr'
diff --git a/rts/Compact.cmm b/rts/Compact.cmm
index 0b98f39..ded79f0 100644
--- a/rts/Compact.cmm
+++ b/rts/Compact.cmm
@@ -188,9 +188,27 @@ eval:
     case
         SMALL_MUT_ARR_PTRS_FROZEN0,
         SMALL_MUT_ARR_PTRS_FROZEN: {
-        // (P_ to) = allocateForCompact(cap, compact, size);
-        // use prim memcpy
-        ccall barf("stg_compactAddWorkerzh: TODO: SMALL_MUT_ARR_PTRS");
+
+        W_ i, size, ptrs;
+        size = SIZEOF_StgMutArrPtrs + WDS(StgMutArrPtrs_size(p));
+        ptrs = StgMutArrPtrs_ptrs(p);
+        ALLOCATE(compact, BYTES_TO_WDS(size), 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);
+        i = 0;
+      loop0:
+        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;
+        }
+        return();
     }
 
     // Everything else we should copy and evaluate the components: