ghci 8.2.2 → 8.4.1

raw patch · 13 files changed

+149/−100 lines, 13 filesdep ~basedep ~ghc-bootdep ~ghc-boot-thPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, ghc-boot, ghc-boot-th, template-haskell

API changes (from Hackage documentation)

Files

• GHCi/BinaryArray.hs +77/−0
• GHCi/CreateBCO.hs +12/−3
• GHCi/InfoTable.hsc +8/−8
• GHCi/Message.hs +5/−16
• GHCi/ObjLink.hs +2/−2
• GHCi/RemoteTypes.hs +5/−7
• GHCi/ResolvedBCO.hs +27/−41
• GHCi/Run.hs +1/−3
• GHCi/Signals.hs +1/−1
• GHCi/TH.hs +5/−1
• GHCi/TH/Binary.hs +0/−1
• changelog.md +0/−12
• ghci.cabal +6/−5

@@ -0,0 +1,77 @@+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-}+-- | Efficient serialisation for GHCi Instruction arrays+--+-- Author: Ben Gamari+--+module GHCi.BinaryArray(putArray, getArray) where++import Foreign.Ptr+import Data.Binary+import Data.Binary.Put (putBuilder)+import qualified Data.Binary.Get.Internal as Binary+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Builder.Internal as BB+import qualified Data.Array.Base as A+import qualified Data.Array.IO.Internals as A+import qualified Data.Array.Unboxed as A+import GHC.Exts+import GHC.IO++-- | An efficient serialiser of 'A.UArray'.+putArray :: Binary i => A.UArray i a -> Put+putArray (A.UArray l u _ arr#) = do+    put l+    put u+    putBuilder $ byteArrayBuilder arr#++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', () #)++-- | An efficient deserialiser of 'A.UArray'.+getArray :: (Binary i, A.Ix i, A.MArray A.IOUArray a IO) => Get (A.UArray i a)+getArray = do+    l <- get+    u <- get+    arr@(A.IOUArray (A.STUArray _ _ _ arr#)) <-+        return $ unsafeDupablePerformIO $ A.newArray_ (l,u)+    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 (I# (sizeofMutableByteArray# arr#)) 0+    return $! unsafeDupablePerformIO $ unsafeFreezeIOUArray arr+  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', () #)++-- this is inexplicably not exported in currently released array versions+unsafeFreezeIOUArray :: A.IOUArray ix e -> IO (A.UArray ix e)+unsafeFreezeIOUArray (A.IOUArray marr) = stToIO (A.unsafeFreezeSTUArray marr)

@@ -25,7 +25,7 @@ import GHC.Arr          ( Array(..) ) import GHC.Exts import GHC.IO--- import Debug.Trace+import Control.Exception (throwIO, ErrorCall(..))  createBCOs :: [ResolvedBCO] -> IO [HValueRef] createBCOs bcos = do@@ -36,6 +36,12 @@   mapM mkRemoteRef hvals  createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue+createBCO _   ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian+  = throwIO (ErrorCall $+        unlines [ "The endianness of the ResolvedBCO does not match"+                , "the systems endianness. Using ghc and iserv in a"+                , "mixed endianness setup is not supported!"+                ]) createBCO arr bco    = do BCO bco# <- linkBCO' arr bco         -- Why do we need mkApUpd0 here?  Otherwise top-level@@ -56,6 +62,9 @@                   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@@ -68,8 +77,8 @@        barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b       insns_barr = barr resolvedBCOInstrs-      bitmap_barr = barr resolvedBCOBitmap-      literals_barr = barr resolvedBCOLits+      bitmap_barr = barr (toWordArray resolvedBCOBitmap)+      literals_barr = barr (toWordArray resolvedBCOLits)    PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs   IO $ \s ->

@@ -1,5 +1,8 @@ {-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-} +-- Get definitions for the structs, constants & config etc.+#include "Rts.h"+ -- | -- Run-time info table support.  This module provides support for -- creating and reading info tables /in the running program/.@@ -17,23 +20,20 @@ import Data.Maybe (fromJust) #endif import Foreign-import Foreign.C-import GHC.Ptr-import GHC.Exts-import System.IO.Unsafe+import Foreign.C -- needed for 2nd stage+import GHC.Ptr -- needed for 2nd stage+import GHC.Exts -- needed for 2nd stage+import System.IO.Unsafe -- needed for 2nd stage  type ItblCodes = Either [Word8] [Word32] --- Get definitions for the structs, constants & config etc.-#include "Rts.h"- -- Ultra-minimalist version specially for constructors #if SIZEOF_VOID_P == 8 type HalfWord = Word32 #elif SIZEOF_VOID_P == 4 type HalfWord = Word16 #else-#error Uknown SIZEOF_VOID_P+#error Unknown SIZEOF_VOID_P #endif  type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))

@@ -48,11 +48,7 @@ import Data.IORef import Data.Map (Map) import GHC.Generics-#if MIN_VERSION_base(4,9,0) import GHC.Stack.CCS-#else-import GHC.Stack as GHC.Stack.CCS-#endif import qualified Language.Haskell.TH        as TH import qualified Language.Haskell.TH.Syntax as TH import System.Exit@@ -244,6 +240,7 @@    AddDependentFile :: FilePath -> THMessage (THResult ())   AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())+  AddCorePlugin :: String -> THMessage (THResult ())   AddTopDecls :: [TH.Dec] -> THMessage (THResult ())   AddForeignFile :: ForeignSrcLang -> String -> THMessage (THResult ())   IsExtEnabled :: Extension -> THMessage (THResult Bool)@@ -282,7 +279,8 @@     15 -> THMsg <$> EndRecover <$> get     16 -> return (THMsg RunTHDone)     17 -> THMsg <$> AddModFinalizer <$> get-    _  -> THMsg <$> (AddForeignFile <$> get <*> get)+    18 -> THMsg <$> (AddForeignFile <$> get <*> get)+    _  -> THMsg <$> AddCorePlugin <$> get  putTHMessage :: THMessage a -> Put putTHMessage m = case m of@@ -305,6 +303,7 @@   RunTHDone                   -> putWord8 16   AddModFinalizer a           -> putWord8 17 >> put a   AddForeignFile lang a       -> putWord8 18 >> put lang >> put a+  AddCorePlugin a             -> putWord8 19 >> put a   data EvalOpts = EvalOpts@@ -384,17 +383,7 @@ fromSerializableException (EExitCode c) = toException c fromSerializableException (EOtherException str) = toException (ErrorCall str) --- NB: Replace this with a derived instance once we depend on GHC 8.0--- as the minimum-instance Binary ExitCode where-  put ExitSuccess      = putWord8 0-  put (ExitFailure ec) = putWord8 1 >> put ec-  get = do-    w <- getWord8-    case w of-      0 -> pure ExitSuccess-      _ -> ExitFailure <$> get-+instance Binary ExitCode instance Binary SerializableException  data THResult a

@@ -180,14 +180,14 @@ #include "ghcautoconf.h"  cLeadingUnderscore :: Bool-#ifdef LEADING_UNDERSCORE+#if defined(LEADING_UNDERSCORE) cLeadingUnderscore = True #else cLeadingUnderscore = False #endif  isWindowsHost :: Bool-#if mingw32_HOST_OS+#if defined(mingw32_HOST_OS) isWindowsHost = True #else isWindowsHost = False

@@ -30,14 +30,12 @@ -- RemotePtr  -- Static pointers only; don't use this for heap-resident pointers.--- Instead use HValueRef.--#include "MachDeps.h"-#if SIZEOF_HSINT == 4-newtype RemotePtr a = RemotePtr Word32-#elif SIZEOF_HSINT == 8+-- Instead use HValueRef. We will fix the remote pointer to be 64 bits. This+-- should cover 64 and 32bit systems, and permits the exchange of remote ptrs+-- between machines of different word size. For exmaple, when connecting to+-- an iserv instance on a different architecture with different word size via+-- -fexternal-interpreter. newtype RemotePtr a = RemotePtr Word64-#endif  toRemotePtr :: Ptr a -> RemotePtr a toRemotePtr p = RemotePtr (fromIntegral (ptrToWordPtr p))

@@ -1,78 +1,64 @@ {-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,-    BangPatterns #-}+    BangPatterns, CPP #-} module GHCi.ResolvedBCO   ( ResolvedBCO(..)   , ResolvedBCOPtr(..)+  , isLittleEndian   ) where  import SizedSeq import GHCi.RemoteTypes import GHCi.BreakArray -import Control.Monad.ST import Data.Array.Unboxed-import Data.Array.Base import Data.Binary import GHC.Generics+import GHCi.BinaryArray ++#include "MachDeps.h"++isLittleEndian :: Bool+#if defined(WORDS_BIGENDIAN)+isLittleEndian = True+#else+isLittleEndian = False+#endif+ -- ----------------------------------------------------------------------------- -- ResolvedBCO --- A A ResolvedBCO is one in which all the Name references have been--- resolved to actual addresses or RemoteHValues.+-- | 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 Word,           -- insns-        resolvedBCOBitmap :: UArray Int Word,           -- bitmap-        resolvedBCOLits   :: UArray Int Word,           -- non-ptrs+        resolvedBCOInstrs :: UArray Int Word16,         -- insns+        resolvedBCOBitmap :: UArray Int Word64,         -- bitmap+        resolvedBCOLits   :: UArray Int Word64,         -- non-ptrs         resolvedBCOPtrs   :: (SizedSeq ResolvedBCOPtr)  -- ptrs    }    deriving (Generic, Show) +-- | The Binary instance for ResolvedBCOs.+--+-- Note, that we do encode the endianness, however there is no support for mixed+-- endianness setups.  This is primarily to ensure that ghc and iserv share the+-- same endianness. instance Binary ResolvedBCO where   put ResolvedBCO{..} = do+    put resolvedBCOIsLE     put resolvedBCOArity     putArray resolvedBCOInstrs     putArray resolvedBCOBitmap     putArray resolvedBCOLits     put resolvedBCOPtrs-  get = ResolvedBCO <$> get <*> getArray <*> getArray <*> getArray <*> get---- Specialized versions of the binary get/put for UArray Int Word.--- This saves a bit of time and allocation over using the default--- get/put, because we get specialisd code and also avoid serializing--- the bounds.-putArray :: UArray Int Word -> Put-putArray a@(UArray _ _ n _) = do-  put n-  mapM_ put (elems a)--getArray :: Get (UArray Int Word)-getArray = do-  n  <- get-  xs <- gets n []-  return $! mkArray n xs- where-  gets 0 xs = return xs-  gets n xs = do-    x <- get-    gets (n-1) (x:xs)--  mkArray :: Int -> [Word] -> UArray Int Word-  mkArray n0 xs0 = runST $ do-    !marr <- newArray (0,n0-1) 0-    let go 0 _ = return ()-        go _ [] = error "mkArray"-        go n (x:xs) = do-          let n' = n-1-          unsafeWrite marr n' x-          go n' xs-    go n0 xs0-    unsafeFreezeSTUArray marr+  get = ResolvedBCO+        <$> get <*> get <*> getArray <*> getArray <*> getArray <*> get  data ResolvedBCOPtr   = ResolvedBCORef {-# UNPACK #-} !Int

@@ -344,9 +344,7 @@  getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue) getIdValFromApStack apStack (I# stackDepth) = do-   case getApStackVal# apStack (stackDepth +# 1#) of-                                -- The +1 is magic!  I don't know where it comes-                                -- from, but this makes things line up.  --SDM+   case getApStackVal# apStack stackDepth of         (# ok, result #) ->             case ok of               0# -> return Nothing -- AP_STACK not found

@@ -5,7 +5,7 @@ import Control.Exception import System.Mem.Weak  ( deRefWeak ) -#ifndef mingw32_HOST_OS+#if !defined(mingw32_HOST_OS) import System.Posix.Signals #endif 

@@ -97,6 +97,7 @@  import Control.Exception import qualified Control.Monad.Fail as Fail+import Control.Monad.IO.Class (MonadIO (..)) import Data.Binary import Data.Binary.Put import Data.ByteString (ByteString)@@ -160,6 +161,9 @@     THException str -> throwIO (GHCiQException s str)     THComplete res -> return (res, s) +instance MonadIO GHCiQ where+  liftIO m = GHCiQ $ \s -> fmap (,s) m+ instance TH.Quasi GHCiQ where   qNewName str = ghcCmd (NewName str)   qReport isError msg = ghcCmd (Report isError msg)@@ -190,12 +194,12 @@   qReifyModule m = ghcCmd (ReifyModule m)   qReifyConStrictness name = ghcCmd (ReifyConStrictness name)   qLocation = fromMaybe noLoc . qsLocation <$> getState-  qRunIO m = GHCiQ $ \s -> fmap (,s) m   qAddDependentFile file = ghcCmd (AddDependentFile file)   qAddTopDecls decls = ghcCmd (AddTopDecls decls)   qAddForeignFile str lang = ghcCmd (AddForeignFile str lang)   qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=                          ghcCmd . AddModFinalizer+  qAddCorePlugin str = ghcCmd (AddCorePlugin str)   qGetQ = GHCiQ $ \s ->     let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a         lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m

@@ -44,7 +44,6 @@ instance Binary TH.Match instance Binary TH.Fixity instance Binary TH.TySynEqn-instance Binary TH.FamFlavour instance Binary TH.FunDep instance Binary TH.AnnTarget instance Binary TH.RuleBndr

@@ -1,15 +1,3 @@-## 8.2.2 Nov 2017--  * Bundled with GHC 8.2.2--## 8.2.1 Jul 2017--  * Bundled with GHC 8.2.1--  * Add support for StaticPointers in GHCi (#12356)--  * Move Typeable Binary instances to `binary` package- ## 8.0.1  *Feb 2016*    * Bundled with GHC 8.0.1

@@ -1,5 +1,5 @@ name:           ghci-version:        8.2.2+version:        8.4.1 license:        BSD3 license-file:   LICENSE category:       GHC@@ -54,6 +54,7 @@      exposed-modules:         GHCi.BreakArray+        GHCi.BinaryArray         GHCi.Message         GHCi.ResolvedBCO         GHCi.RemoteTypes@@ -65,15 +66,15 @@      Build-Depends:         array            == 0.5.*,-        base             >= 4.8 && < 4.11,+        base             >= 4.8 && < 4.12,         binary           == 0.8.*,         bytestring       == 0.10.*,         containers       == 0.5.*,         deepseq          == 1.4.*,         filepath         == 1.4.*,-        ghc-boot         == 8.2.2,-        ghc-boot-th      == 8.2.2,-        template-haskell == 2.12.*,+        ghc-boot         == 8.4.1,+        ghc-boot-th      == 8.4.1,+        template-haskell == 2.13.*,         transformers     == 0.5.*      if !os(windows)