From 284cca51f07c70c03ce602c963e22acf7333180b Mon Sep 17 00:00:00 2001
From: David Hewson <david.hewson@tracsis.com>
Date: Fri, 3 May 2019 22:18:10 +0100
Subject: support small arrays and CONSTR_NOCAF in ghc-heap

---
 libraries/ghc-heap/GHC/Exts/Heap.hs          |  6 ++++++
 libraries/ghc-heap/GHC/Exts/Heap/Closures.hs | 10 ++++++++++
 2 files changed, 16 insertions(+)

(limited to 'libraries/ghc-heap')

diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs
index 16b00e0dfb..d3b9097b2d 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap.hs
@@ -248,6 +248,12 @@ getClosure x = do
                         ++ "found " ++ show (length rawWds)
             pure $ MutArrClosure itbl (rawWds !! 0) (rawWds !! 1) pts
 
+        t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> do
+            unless (length rawWds >= 1) $
+                fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "
+                        ++ "found " ++ show (length rawWds)
+            pure $ SmallMutArrClosure itbl (rawWds !! 0) pts
+
         t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
             pure $ MutVarClosure itbl (head pts)
 
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
index 38fef83940..025c30aaa1 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
@@ -221,6 +221,15 @@ data GenClosure b
         -- Card table ignored
         }
 
+    -- | A @SmallMutableArray#@
+    --
+    -- @since 8.10.1
+  | SmallMutArrClosure
+        { info       :: !StgInfoTable
+        , mccPtrs    :: !Word           -- ^ Number of pointers
+        , mccPayload :: ![b]            -- ^ Array payload
+        }
+
     -- | An @MVar#@, with a queue of thread state objects blocking on them
   | MVarClosure
         { info       :: !StgInfoTable
@@ -321,6 +330,7 @@ allClosures (APStackClosure {..}) = fun:payload
 allClosures (BCOClosure {..}) = [instrs,literals,bcoptrs]
 allClosures (ArrWordsClosure {}) = []
 allClosures (MutArrClosure {..}) = mccPayload
+allClosures (SmallMutArrClosure {..}) = mccPayload
 allClosures (MutVarClosure {..}) = [var]
 allClosures (MVarClosure {..}) = [queueHead,queueTail,value]
 allClosures (FunClosure {..}) = ptrArgs
-- 
cgit v1.2.1