Fix FastString put looping and get off by one error

3 files changed, 24 insertions, 16 deletions

diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index 27f6d355f1..05a7deb0ef 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -167,7 +167,7 @@ instance GBinary (M1 i c a) => GSumBinary (M1 i c a) where
   gsget _   = gget
 
 sumSize :: forall f. GSumBinary f => Int8
-sumSize = fromIntegral $ natVal' (proxy# @Nat @(SumSize f))
+sumSize = fromIntegral $ natVal' (proxy# :: Proxy# (SumSize f))
 
 maxIndex :: forall f. GSumBinary f => Int8
 maxIndex = sumSize @f - 1
diff --git a/compiler/utils/Binary/Internal.hs b/compiler/utils/Binary/Internal.hs
index edc25afe2b..32fedd28ac 100755
--- a/compiler/utils/Binary/Internal.hs
+++ b/compiler/utils/Binary/Internal.hs
@@ -42,6 +42,7 @@ module Binary.Internal (
   putByte, getByte,

 

   putByteString, getByteString,

+  putFS, getFS,

   putAFastString, getAFastString,

 

   putNonBindingName, putBindingName,

@@ -189,12 +190,10 @@ getInt64 = getSLEB128
 -- -----------------------------------------------------------------------------

 

 putBin :: Bin a -> Put ()

-putBin (BinPtr !p) = putInt p

+putBin (BinPtr !p) = putWord32 (fromIntegral p :: Word32)

 

 getBin :: Get (Bin a)

-getBin = do

-  p <- getInt

-  return . BinPtr $ fromIntegral p

+getBin = BinPtr . fromIntegral <$> getWord32

 

 -- -----------------------------------------------------------------------------

 -- ByteString

@@ -221,11 +220,19 @@ getByteString = do
 -- -----------------------------------------------------------------------------

 

 putAFastString :: FastString -> Put ()

-putAFastString fs = put_fs <$> userDataP >>= ($ fs)

+putAFastString fs = put_fs <$!> userDataP >>= ($! fs)

 

 getAFastString :: Get FastString

 getAFastString = get_fs =<< userDataG

 

+putFS :: FastString -> Put ()

+putFS = putByteString . bytesFS

+

+getFS :: Get FastString

+getFS = do

+  l <- getInt

+  getPrim l (\src -> pure $! mkFastStringBytes src l)

+

 putNonBindingName :: Name -> Put ()

 putNonBindingName n = put_nonbinding_name <$> userDataP >>= ($ n)

 

@@ -353,9 +360,9 @@ putInt i = putSLEB128 (fromIntegral i :: Int64)
 getInt :: Get Int

 getInt = (fromIntegral $!) <$> (getSLEB128 :: Get Int64)

 

----------------------------------------------------------

+--------------------------------------------------------------------------------

 -- The Dictionary

----------------------------------------------------------

+--------------------------------------------------------------------------------

 

 type Dictionary = Array Int FastString -- The dictionary

                                        -- Should be 0-indexed

@@ -363,19 +370,19 @@ type Dictionary = Array Int FastString -- The dictionary
 putDictionary :: Int -> UniqFM (Int,FastString) -> Put ()

 putDictionary sz dict = do

   putInt sz

-  mapM_ putAFastString (elems (array (0,sz-1) (nonDetEltsUFM dict)))

+  mapM_ putFS (elems (array (0,sz-1) (nonDetEltsUFM dict)))

     -- It's OK to use nonDetEltsUFM here because the elements have indices

     -- that array uses to create order

 

 getDictionary :: Get Dictionary

 getDictionary = do

   sz <- getInt

-  elems <- sequence (GhcPrelude.take sz (repeat getAFastString))

+  elems <- sequence (GhcPrelude.take sz (repeat getFS))

   return (listArray (0,sz-1) elems)

 

----------------------------------------------------------

+--------------------------------------------------------------------------------

 -- The Symbol Table

----------------------------------------------------------

+--------------------------------------------------------------------------------

 

 -- On disk, the symbol table is an array of IfExtName, when

 -- reading it in we turn it into a SymbolTable.

diff --git a/compiler/utils/Binary/Unsafe.hs b/compiler/utils/Binary/Unsafe.hs
index 67dfec53e1..a9aee32c3d 100755
--- a/compiler/utils/Binary/Unsafe.hs
+++ b/compiler/utils/Binary/Unsafe.hs
@@ -5,6 +5,7 @@ module Binary.Unsafe where
 

 import GhcPrelude

 

+import Control.Monad.Fail

 import Control.Monad.Reader

 import Data.IORef

 import Data.ByteString (ByteString)

@@ -47,7 +48,7 @@ withBinBuffer (BinData sz arr) action =
 -- -----------------------------------------------------------------------------

 

 newtype Put a = Put { unput :: ReaderT EnvP IO a }

-  deriving (Functor, Applicative, Monad)

+  deriving (Functor, Applicative, Monad, MonadFail)

 

 -- Internal reader data for `Put` monad.

 data EnvP

@@ -156,7 +157,7 @@ tellP = BinPtr <$> offsetP
 -- -----------------------------------------------------------------------------

 

 newtype Get a = Get { unget :: ReaderT EnvG IO a }

-  deriving (Functor, Applicative, Monad)

+  deriving (Functor, Applicative, Monad, MonadFail)

 

 -- Internal reader data for `Get` monad.

 data EnvG

@@ -168,7 +169,7 @@ data EnvG
      }

 

 runGetIO :: BinData -> Get a -> IO a

-runGetIO bd m = (runReaderT (unget m) =<< mkEnvG bd)

+runGetIO bd m = runReaderT (unget m) =<< mkEnvG bd

 

 runGet :: BinData -> Get a -> a

 runGet bd = unsafePerformIO . runGetIO bd

@@ -214,7 +215,7 @@ getPrim :: Int -> (Ptr Word8 -> IO a) -> Get a
 getPrim n f = do

   ix  <- getOffset

   end <- getEnd

-  when (ix + n >= end) $

+  when (ix + n > end) $

     ioG $ ioError (mkIOError eofErrorType "Binary.Internal.getPrim" Nothing Nothing)

   arr <- getArr

   do