Avoid UArray when indexing is not required

`UnlinkedBCO`'s can occur many times in the heap. Each `UnlinkedBCO`
references two `UArray`'s but never indexes them. They are only needed
to encode the elements into a `ByteArray#`. The three words for
the lower bound, upper bound and number of elements are essentially
unused, thus we replace `UArray` with a wrapper around `ByteArray#`.
This saves us up to three words for each `UnlinkedBCO`.

Further, to avoid re-allocating these words for `ResolvedBCO`, we repeat
the procedure for `ResolvedBCO` and add custom `Binary` and `Show` instances.

For example, agda's repl session has around 360_000 UnlinkedBCO's,
so avoiding these three words is already saving us around 8MB residency.

compiler/GHC/ByteCode/Asm.hs

@@ -213,8 +213,8 @@ assembleBCO platform (ProtoBCO { protoBCOName       = nm
              (text "bytecode instruction count mismatch")
 
   let asm_insns = ssElts final_insns
-      insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns
-      bitmap_arr = mkBitmapArray bsize bitmap
+      !insns_arr =  mkBCOByteArray $ Array.listArray (0 :: Int, fromIntegral n_insns - 1) asm_insns
+      !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap
       ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSizedSeq final_lits) (fromSizedSeq final_ptrs)
 
   -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
@@ -224,7 +224,7 @@ assembleBCO platform (ProtoBCO { protoBCOName       = nm
 
   return ul_bco
 
-mkBitmapArray :: Word -> [StgWord] -> UArray Int Word64
+mkBitmapArray :: Word -> [StgWord] -> UArray Int Word
 -- Here the return type must be an array of Words, not StgWords,
 -- because the underlying ByteArray# will end up as a component
 -- of a BCO object.

compiler/GHC/ByteCode/Linker.hs

@@ -60,10 +60,13 @@ linkBCO interp le bco_ix
            (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
   -- fromIntegral Word -> Word64 should be a no op if Word is Word64
   -- otherwise it will result in a cast to longlong on 32bit systems.
-  lits <- mapM (fmap fromIntegral . lookupLiteral interp le) (elemsFlatBag lits0)
+  (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp le) (elemsFlatBag lits0)
   ptrs <- mapM (resolvePtr interp le bco_ix) (elemsFlatBag ptrs0)
-  return (ResolvedBCO isLittleEndian arity insns bitmap
-              (listArray (0, fromIntegral (sizeFlatBag lits0)-1) lits)
+  let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits
+  return (ResolvedBCO isLittleEndian arity
+              insns
+              bitmap
+              (mkBCOByteArray lits')
               (addListToSS emptySS ptrs))
 
 lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word

compiler/GHC/ByteCode/Types.hs

 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE MagicHash                  #-}
+{-# LANGUAGE UnliftedNewtypes           #-}
 --
 --  (c) The University of Glasgow 2002-2006
 --
@@ -8,6 +10,7 @@
 -- | Bytecode assembler types
 module GHC.ByteCode.Types
   ( CompiledByteCode(..), seqCompiledByteCode
+  , BCOByteArray(..), mkBCOByteArray
   , FFIInfo(..)
   , RegBitmap(..)
   , NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo
@@ -34,10 +37,10 @@ import GHCi.BreakArray
 import GHCi.RemoteTypes
 import GHCi.FFI
 import Control.DeepSeq
+import GHCi.ResolvedBCO ( BCOByteArray(..), mkBCOByteArray )
 
 import Foreign
 import Data.Array
-import Data.Array.Base  ( UArray(..) )
 import Data.ByteString (ByteString)
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
@@ -153,8 +156,8 @@ data UnlinkedBCO
    = UnlinkedBCO {
         unlinkedBCOName   :: !Name,
         unlinkedBCOArity  :: {-# UNPACK #-} !Int,
-        unlinkedBCOInstrs :: !(UArray Int Word16),      -- insns
-        unlinkedBCOBitmap :: !(UArray Int Word64),      -- bitmap
+        unlinkedBCOInstrs :: !(BCOByteArray Word16),      -- insns
+        unlinkedBCOBitmap :: !(BCOByteArray Word),      -- bitmap
         unlinkedBCOLits   :: !(FlatBag BCONPtr),       -- non-ptrs
         unlinkedBCOPtrs   :: !(FlatBag BCOPtr)         -- ptrs
    }

libraries/ghci/GHCi/CreateBCO.hs

@@ -68,9 +68,6 @@ createBCO arr bco
                   return (HValue final_bco) }
 
 
-toWordArray :: UArray Int Word64 -> UArray Int Word
-toWordArray = amap fromIntegral
-
 linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO
 linkBCO' arr ResolvedBCO{..} = do
   let
@@ -80,11 +77,10 @@ linkBCO' arr ResolvedBCO{..} = do
       !(I# arity#)  = resolvedBCOArity
 
       !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]
-
-      barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b
-      insns_barr = barr resolvedBCOInstrs
-      bitmap_barr = barr (toWordArray resolvedBCOBitmap)
-      literals_barr = barr (toWordArray resolvedBCOLits)
+      barr arr# = if I# (sizeofByteArray# arr#) == 0 then empty# else arr#
+      insns_barr = barr (getBCOByteArray resolvedBCOInstrs)
+      bitmap_barr = barr (getBCOByteArray resolvedBCOBitmap)
+      literals_barr = barr (getBCOByteArray resolvedBCOLits)
 
   PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs
   IO $ \s ->

libraries/ghci/GHCi/ResolvedBCO.hs

 {-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,
-    BangPatterns, CPP #-}
+    BangPatterns, CPP, MagicHash, FlexibleInstances, FlexibleContexts,
+    TypeApplications, ScopedTypeVariables, UnboxedTuples #-}
 module GHCi.ResolvedBCO
   ( ResolvedBCO(..)
   , ResolvedBCOPtr(..)
   , isLittleEndian
+  , BCOByteArray(..)
+  , mkBCOByteArray
   ) where
 
 import Prelude -- See note [Why do we import Prelude here?]
@@ -11,11 +14,19 @@ import GHC.Data.SizedSeq
 import GHCi.RemoteTypes
 import GHCi.BreakArray
 
-import Data.Array.Unboxed
 import Data.Binary
+import Data.Binary.Put (putBuilder)
 import GHC.Generics
-import GHCi.BinaryArray
 
+import Foreign.Ptr
+import Data.Array.Byte
+import qualified Data.Binary.Get.Internal as Binary
+import qualified Data.ByteString.Builder as BB
+import qualified Data.ByteString.Builder.Internal as BB
+import GHC.Exts
+import Data.Array.Base (UArray(..))
+
+import GHC.IO
 
 #include "MachDeps.h"
 
@@ -32,19 +43,35 @@ isLittleEndian = True
 -- | A 'ResolvedBCO' is one in which all the 'Name' references have been
 -- resolved to actual addresses or 'RemoteHValues'.
 --
--- Note, all arrays are zero-indexed (we assume this when
--- serializing/deserializing)
 data ResolvedBCO
    = ResolvedBCO {
         resolvedBCOIsLE   :: Bool,
         resolvedBCOArity  :: {-# UNPACK #-} !Int,
-        resolvedBCOInstrs :: UArray Int Word16,         -- insns
-        resolvedBCOBitmap :: UArray Int Word64,         -- bitmap
-        resolvedBCOLits   :: UArray Int Word64,         -- non-ptrs
+        resolvedBCOInstrs :: BCOByteArray Word16,       -- insns
+        resolvedBCOBitmap :: BCOByteArray Word,         -- bitmap
+        resolvedBCOLits   :: BCOByteArray Word,         -- non-ptrs
         resolvedBCOPtrs   :: (SizedSeq ResolvedBCOPtr)  -- ptrs
    }
    deriving (Generic, Show)
 
+-- | Wrapper for a 'ByteArray#'.
+-- The phantom type tells what elements are stored in the 'ByteArray#'.
+-- Creating a 'ByteArray#' can be achieved using 'UArray''s API,
+-- where the underlying 'ByteArray#' can be unpacked.
+data BCOByteArray a
+  = BCOByteArray {
+        getBCOByteArray :: !ByteArray#
+  }
+
+mkBCOByteArray :: UArray Int a -> BCOByteArray a
+mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr
+
+instance Show (BCOByteArray Word16) where
+  showsPrec _ _ = showString "BCOByteArray Word16"
+
+instance Show (BCOByteArray Word) where
+  showsPrec _ _ = showString "BCOByteArray Word"
+
 -- | The Binary instance for ResolvedBCOs.
 --
 -- Note, that we do encode the endianness, however there is no support for mixed
@@ -54,12 +81,16 @@ instance Binary ResolvedBCO where
   put ResolvedBCO{..} = do
     put resolvedBCOIsLE
     put resolvedBCOArity
-    putArray resolvedBCOInstrs
-    putArray resolvedBCOBitmap
-    putArray resolvedBCOLits
+    put resolvedBCOInstrs
+    put resolvedBCOBitmap
+    put resolvedBCOLits
     put resolvedBCOPtrs
-  get = ResolvedBCO
-        <$> get <*> get <*> getArray <*> getArray <*> getArray <*> get
+  get = ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get
+
+instance Binary (BCOByteArray a) where
+  put = putBCOByteArray
+  get = decodeBCOByteArray
+
 
 data ResolvedBCOPtr
   = ResolvedBCORef {-# UNPACK #-} !Int
@@ -75,3 +106,65 @@ data ResolvedBCOPtr
   deriving (Generic, Show)
 
 instance Binary ResolvedBCOPtr
+
+-- --------------------------------------------------------
+-- Serialisers for 'BCOByteArray'
+-- --------------------------------------------------------
+
+putBCOByteArray :: BCOByteArray a -> Put
+putBCOByteArray (BCOByteArray bar) = do
+  put (I# (sizeofByteArray# bar))
+  putBuilder $ byteArrayBuilder bar
+
+decodeBCOByteArray :: Get (BCOByteArray a)
+decodeBCOByteArray = do
+  n <- get
+  getByteArray n
+
+byteArrayBuilder :: ByteArray# -> BB.Builder
+byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#))
+  where
+    go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a
+    go !inStart !inEnd k (BB.BufferRange outStart outEnd)
+      -- There is enough room in this output buffer to write all remaining array
+      -- contents
+      | inRemaining <= outRemaining = do
+          copyByteArrayToAddr arr# inStart outStart inRemaining
+          k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd)
+      -- There is only enough space for a fraction of the remaining contents
+      | otherwise = do
+          copyByteArrayToAddr arr# inStart outStart outRemaining
+          let !inStart' = inStart + outRemaining
+          return $! BB.bufferFull 1 outEnd (go inStart' inEnd k)
+      where
+        inRemaining  = inEnd - inStart
+        outRemaining = outEnd `minusPtr` outStart
+
+    copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()
+    copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) =
+        IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of
+                     s' -> (# s', () #)
+
+getByteArray :: Int -> Get (BCOByteArray a)
+getByteArray nbytes@(I# nbytes#) = do
+    let !(MutableByteArray arr#) = unsafeDupablePerformIO $
+          IO $ \s -> case newByteArray# nbytes# s of
+                (# s', mbar #) -> (# s', MutableByteArray mbar #)
+    let go 0 _ = return ()
+        go !remaining !off = do
+            Binary.readNWith n $ \ptr ->
+              copyAddrToByteArray ptr arr# off n
+            go (remaining - n) (off + n)
+          where n = min chunkSize remaining
+    go nbytes 0
+    return $! unsafeDupablePerformIO $
+      IO $ \s -> case unsafeFreezeByteArray# arr# s of
+          (# s', bar #) -> (# s', BCOByteArray bar #)
+  where
+    chunkSize = 10*1024
+
+    copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld
+                        -> Int -> Int -> IO ()
+    copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) =
+        IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of
+                     s' -> (# s', () #)

testsuite/tests/ghci/should_run/BinaryArray.hs

-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts, MagicHash, ScopedTypeVariables #-}
 import Data.Binary.Get
 import Data.Binary.Put
+import Data.Binary (get, put)
+import Data.Array.Byte
 import Data.Array.Unboxed as AU
 import Data.Array.IO (IOUArray)
 import Data.Array.MArray (MArray)
 import Data.Array as A
+import Data.Array.Base as A
 import GHCi.BinaryArray
+import GHCi.ResolvedBCO
 import GHC.Word
 
 roundtripTest :: (IArray UArray a, MArray IOUArray a IO, Eq a)
@@ -18,6 +22,17 @@ roundtripTest arr =
            | otherwise    -> putStrLn "failed to round-trip"
          Left _           -> putStrLn "deserialization failed"
 
+roundtripTestByteArray :: forall a . (IArray UArray a, MArray IOUArray a IO, Eq a)
+              => UArray Int a -> IO ()
+roundtripTestByteArray (UArray _ _ _ arr#) =
+    let val  = BCOByteArray arr# :: BCOByteArray a
+        ser  = Data.Binary.Put.runPut $ put val
+    in case Data.Binary.Get.runGetOrFail (get :: Get (BCOByteArray a)) ser of
+         Right (_, _, BCOByteArray arr'# )
+           | ByteArray arr# == ByteArray arr'#  -> return ()
+           | otherwise                          -> putStrLn "failed to round-trip"
+         Left _                                 -> putStrLn "deserialization failed"
+
 main :: IO ()
 main = do
     roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Int)
@@ -27,3 +42,10 @@ main = do
     roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word32)
     roundtripTest (AU.listArray (1,500) [1..] :: UArray Int Word64)
     roundtripTest (AU.listArray (1,500) ['a'..] :: UArray Int Char)
+    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Int)
+    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word)
+    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word8)
+    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word16)
+    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word32)
+    roundtripTestByteArray (AU.listArray (1,500) [1..] :: UArray Int Word64)
+    roundtripTestByteArray (AU.listArray (1,500) ['a'..] :: UArray Int Char)