packages feed

ghci 8.2.2 → 8.10.2

raw patch · 18 files changed

Files

+ GHCi/BinaryArray.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-}+-- | Efficient serialisation for GHCi Instruction arrays+--+-- Author: Ben Gamari+--+module GHCi.BinaryArray(putArray, getArray) where++import Prelude+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)
GHCi/BreakArray.hs view
@@ -19,17 +19,15 @@ module GHCi.BreakArray     (       BreakArray-#ifdef GHCI           (BA) -- constructor is exported only for ByteCodeGen     , newBreakArray     , getBreak     , setBreakOn     , setBreakOff     , showBreakArray-#endif     ) where -#ifdef GHCI+import Prelude -- See note [Why do we import Prelude here?] import Control.Monad import Data.Word import GHC.Word@@ -115,6 +113,3 @@  readBreakArray :: BreakArray -> Int -> IO Word8 readBreakArray (BA array) (I# i) = readBA# array i-#else-data BreakArray-#endif
GHCi/CreateBCO.hs view
@@ -13,6 +13,7 @@ -- | Create real byte-code objects from 'ResolvedBCO's. module GHCi.CreateBCO (createBCOs) where +import Prelude -- See note [Why do we import Prelude here?] import GHCi.ResolvedBCO import GHCi.RemoteTypes import GHCi.BreakArray@@ -25,7 +26,7 @@ import GHC.Arr          ( Array(..) ) import GHC.Exts import GHC.IO--- import Debug.Trace+import Control.Exception ( ErrorCall(..) )  createBCOs :: [ResolvedBCO] -> IO [HValueRef] createBCOs bcos = do@@ -36,6 +37,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 +63,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 +78,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 ->
GHCi/FFI.hsc view
@@ -17,6 +17,7 @@   , freeForeignCallInfo   ) where +import Prelude -- See note [Why do we import Prelude here?] import Control.Exception import Data.Binary import GHC.Generics
GHCi/InfoTable.hsc view
@@ -1,93 +1,43 @@ {-# 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/. -- We use the RTS data structures directly via hsc2hs. -- module GHCi.InfoTable-  ( peekItbl, StgInfoTable(..)-  , conInfoPtr-#ifdef GHCI-  , mkConInfoTable-#endif+  (+    mkConInfoTable   ) where -#if !defined(TABLES_NEXT_TO_CODE)-import Data.Maybe (fromJust)-#endif+import Prelude -- See note [Why do we import Prelude here?] import Foreign import Foreign.C import GHC.Ptr import GHC.Exts-import System.IO.Unsafe--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-#endif--type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))--data StgInfoTable = StgInfoTable {-   entry  :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode-   ptrs   :: HalfWord,-   nptrs  :: HalfWord,-   tipe   :: HalfWord,-   srtlen :: HalfWord,-   code   :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode-  }--peekItbl :: Ptr StgInfoTable -> IO StgInfoTable-peekItbl a0 = do-#if defined(TABLES_NEXT_TO_CODE)-  let entry' = Nothing-#else-  entry' <- Just <$> (#peek StgInfoTable, entry) a0-#endif-  ptrs' <- (#peek StgInfoTable, layout.payload.ptrs) a0-  nptrs' <- (#peek StgInfoTable, layout.payload.nptrs) a0-  tipe' <- (#peek StgInfoTable, type) a0-  srtlen' <- (#peek StgInfoTable, srt_bitmap) a0-  return StgInfoTable-    { entry  = entry'-    , ptrs   = ptrs'-    , nptrs  = nptrs'-    , tipe   = tipe'-    , srtlen = srtlen'-    , code   = Nothing-    }---- | Convert a pointer to an StgConInfo into an info pointer that can be--- used in the header of a closure.-conInfoPtr :: Ptr () -> Ptr ()-conInfoPtr ptr- | ghciTablesNextToCode = ptr `plusPtr` (#size StgConInfoTable)- | otherwise            = ptr+import GHC.Exts.Heap+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS  ghciTablesNextToCode :: Bool-#ifdef TABLES_NEXT_TO_CODE+#if defined(TABLES_NEXT_TO_CODE) ghciTablesNextToCode = True #else ghciTablesNextToCode = False #endif -#ifdef GHCI /* To end */+-- NOTE: Must return a pointer acceptable for use in the header of a closure.+-- If tables_next_to_code is enabled, then it must point the the 'code' field.+-- Otherwise, it should point to the start of the StgInfoTable. mkConInfoTable    :: Int     -- ptr words    -> Int     -- non-ptr words    -> Int     -- constr tag    -> Int     -- pointer tag-   -> [Word8]  -- con desc+   -> ByteString  -- con desc    -> IO (Ptr StgInfoTable)       -- resulting info table is allocated with allocateExec(), and       -- should be freed with freeExec().@@ -103,7 +53,7 @@                          else Just entry_addr,                  ptrs  = fromIntegral ptr_words,                  nptrs = fromIntegral nonptr_words,-                 tipe  = fromIntegral cONSTR,+                 tipe  = CONSTR,                  srtlen = fromIntegral tag,                  code  = if ghciTablesNextToCode                          then Just code'@@ -126,6 +76,7 @@           | ArchARM64           | ArchPPC64           | ArchPPC64LE+          | ArchS390X           | ArchUnknown  deriving Show @@ -149,6 +100,8 @@        ArchPPC64 #elif defined(powerpc64le_HOST_ARCH)        ArchPPC64LE+#elif defined(s390x_HOST_ARCH)+       ArchS390X #else #    if defined(TABLES_NEXT_TO_CODE) #        error Unimplemented architecture@@ -318,6 +271,20 @@                    0x618C0000 .|. lo16 w32,                    0x7D8903A6, 0x4E800420 ] +    ArchS390X ->+        -- Let 0xAABBCCDDEEFFGGHH be the address to jump to.+        -- The following code loads the address into scratch+        -- register r1 and jumps to it.+        --+        --    0:   C0 1E AA BB CC DD       llihf   %r1,0xAABBCCDD+        --    6:   C0 19 EE FF GG HH       iilf    %r1,0xEEFFGGHH+        --   12:   07 F1                   br      %r1++        let w64 = fromIntegral (funPtrToInt a) :: Word64+        in Left [ 0xC0, 0x1E, byte7 w64, byte6 w64, byte5 w64, byte4 w64,+                  0xC0, 0x19, byte3 w64, byte2 w64, byte1 w64, byte0 w64,+                  0x07, 0xF1 ]+     -- This code must not be called. You either need to     -- add your architecture as a distinct case or     -- use non-TABLES_NEXT_TO_CODE mode@@ -368,12 +335,17 @@ pokeConItbl   :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable   -> IO ()-pokeConItbl wr_ptr ex_ptr itbl = do-  let _con_desc = conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB)+pokeConItbl wr_ptr _ex_ptr itbl = do #if defined(TABLES_NEXT_TO_CODE)-  (#poke StgConInfoTable, con_desc) wr_ptr _con_desc+  -- Write the offset to the con_desc from the end of the standard InfoTable+  -- at the first byte.+  let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)+  (#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset #else-  (#poke StgConInfoTable, con_desc) wr_ptr (conDesc itbl)+  -- Write the con_desc address after the end of the info table.+  -- Use itblSize because CPP will not pick up PROFILING when calculating+  -- the offset.+  pokeByteOff wr_ptr itblSize (conDesc itbl) #endif   pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl) @@ -385,28 +357,14 @@        Left  xs -> sizeOf (head xs) * length xs        Right xs -> sizeOf (head xs) * length xs -pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()-pokeItbl a0 itbl = do-#if !defined(TABLES_NEXT_TO_CODE)-  (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))-#endif-  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)-  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)-  (#poke StgInfoTable, type) a0 (tipe itbl)-  (#poke StgInfoTable, srt_bitmap) a0 (srtlen itbl)-#if defined(TABLES_NEXT_TO_CODE)-  let code_offset = (a0 `plusPtr` (#offset StgInfoTable, code))-  case code itbl of-    Nothing -> return ()-    Just (Left xs) -> pokeArray code_offset xs-    Just (Right xs) -> pokeArray code_offset xs-#endif--newExecConItbl :: StgInfoTable -> [Word8] -> IO (FunPtr ())+-- Note: Must return proper pointer for use in a closure+newExecConItbl :: StgInfoTable -> ByteString -> IO (FunPtr ()) newExecConItbl obj con_desc    = alloca $ \pcode -> do-        let lcon_desc = length con_desc + 1{- null terminator -}-            sz = fromIntegral ((#size StgConInfoTable) + sizeOfEntryCode)+        let lcon_desc = BS.length con_desc + 1{- null terminator -}+            -- SCARY+            -- This size represents the number of bytes in an StgConInfoTable.+            sz = fromIntegral (conInfoTableSizeB + sizeOfEntryCode)                -- Note: we need to allocate the conDesc string next to the info                -- table, because on a 64-bit platform we reference this string                -- with a 32-bit offset relative to the info table, so if we@@ -416,9 +374,16 @@         let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz                                     , infoTable = obj }         pokeConItbl wr_ptr ex_ptr cinfo-        pokeArray0 0 (castPtr wr_ptr `plusPtr` fromIntegral sz) con_desc+        BS.useAsCStringLen con_desc $ \(src, len) ->+            copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len+        let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)+        poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)         _flushExec sz ex_ptr -- Cache flush (if needed)+#if defined(TABLES_NEXT_TO_CODE)+        return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB))+#else         return (castPtrToFunPtr ex_ptr)+#endif  foreign import ccall unsafe "allocateExec"   _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)@@ -432,26 +397,5 @@ wORD_SIZE :: Int wORD_SIZE = (#const SIZEOF_HSINT) -fixedInfoTableSizeB :: Int-fixedInfoTableSizeB = 2 * wORD_SIZE--profInfoTableSizeB :: Int-profInfoTableSizeB = (#size StgProfInfo)--stdInfoTableSizeB :: Int-stdInfoTableSizeB-  = (if ghciTablesNextToCode then 0 else wORD_SIZE)-  + (if rtsIsProfiled then profInfoTableSizeB else 0)-  + fixedInfoTableSizeB- conInfoTableSizeB :: Int-conInfoTableSizeB = stdInfoTableSizeB + wORD_SIZE--foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt--rtsIsProfiled :: Bool-rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0--cONSTR :: Int   -- Defined in ClosureTypes.h-cONSTR = (#const CONSTR)-#endif /* GHCI */+conInfoTableSizeB = wORD_SIZE + itblSize
GHCi/Message.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables,-    GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards,-    CPP #-}+    GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}  -- |@@ -23,13 +22,14 @@   , Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe   ) where +import Prelude -- See note [Why do we import Prelude here?] import GHCi.RemoteTypes-import GHCi.InfoTable (StgInfoTable) import GHCi.FFI-import GHCi.TH.Binary ()+import GHCi.TH.Binary () -- For Binary instances import GHCi.BreakArray  import GHC.LanguageExtensions+import GHC.Exts.Heap import GHC.ForeignSrcLang import GHC.Fingerprint import Control.Concurrent@@ -41,18 +41,12 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Dynamic-#if MIN_VERSION_base(4,10,0)--- Previously this was re-exported by Data.Dynamic import Data.Typeable (TypeRep)-#endif import Data.IORef import Data.Map (Map)+import Foreign 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@@ -67,6 +61,7 @@ data Message a where   -- | Exit the iserv process   Shutdown :: Message ()+  RtsRevertCAFs :: Message ()    -- RTS Linker ------------------------------------------- @@ -113,7 +108,7 @@    -> Int     -- non-ptr words    -> Int     -- constr tag    -> Int     -- pointer tag-   -> [Word8] -- constructor desccription+   -> ByteString -- constructor desccription    -> Message (RemotePtr StgInfoTable)    -- | Evaluate a statement@@ -210,6 +205,18 @@                    -> [RemoteRef (TH.Q ())]                    -> Message (QResult ()) +  -- | Remote interface to GHC.Exts.Heap.getClosureData. This is used by+  -- the GHCi debugger to inspect values in the heap for :print and+  -- type reconstruction.+  GetClosure+    :: HValueRef+    -> Message (GenClosure HValueRef)++  -- | Evaluate something. This is used to support :force in GHCi.+  Seq+    :: HValueRef+    -> Message (EvalResult ())+ deriving instance Show (Message a)  @@ -235,6 +242,7 @@   LookupName :: Bool -> String -> THMessage (THResult (Maybe TH.Name))   Reify :: TH.Name -> THMessage (THResult TH.Info)   ReifyFixity :: TH.Name -> THMessage (THResult (Maybe TH.Fixity))+  ReifyType :: TH.Name -> THMessage (THResult TH.Type)   ReifyInstances :: TH.Name -> [TH.Type] -> THMessage (THResult [TH.Dec])   ReifyRoles :: TH.Name -> THMessage (THResult [TH.Role])   ReifyAnnotations :: TH.AnnLookup -> TypeRep@@ -243,14 +251,17 @@   ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness])    AddDependentFile :: FilePath -> THMessage (THResult ())+  AddTempFile :: String -> THMessage (THResult FilePath)   AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())+  AddCorePlugin :: String -> THMessage (THResult ())   AddTopDecls :: [TH.Dec] -> THMessage (THResult ())-  AddForeignFile :: ForeignSrcLang -> String -> THMessage (THResult ())+  AddForeignFilePath :: ForeignSrcLang -> FilePath -> THMessage (THResult ())   IsExtEnabled :: Extension -> THMessage (THResult Bool)   ExtsEnabled :: THMessage (THResult [Extension])    StartRecover :: THMessage ()   EndRecover :: Bool -> THMessage ()+  FailIfErrs :: THMessage (THResult ())    -- | Indicates that this RunTH is finished, and the next message   -- will be the result of RunTH (a QResult).@@ -275,14 +286,19 @@     8  -> THMsg <$> ReifyModule <$> get     9  -> THMsg <$> ReifyConStrictness <$> get     10 -> THMsg <$> AddDependentFile <$> get-    11 -> THMsg <$> AddTopDecls <$> get-    12 -> THMsg <$> (IsExtEnabled <$> get)-    13 -> THMsg <$> return ExtsEnabled-    14 -> THMsg <$> return StartRecover-    15 -> THMsg <$> EndRecover <$> get-    16 -> return (THMsg RunTHDone)-    17 -> THMsg <$> AddModFinalizer <$> get-    _  -> THMsg <$> (AddForeignFile <$> get <*> get)+    11 -> THMsg <$> AddTempFile <$> get+    12 -> THMsg <$> AddTopDecls <$> get+    13 -> THMsg <$> (IsExtEnabled <$> get)+    14 -> THMsg <$> return ExtsEnabled+    15 -> THMsg <$> return StartRecover+    16 -> THMsg <$> EndRecover <$> get+    17 -> THMsg <$> return FailIfErrs+    18 -> return (THMsg RunTHDone)+    19 -> THMsg <$> AddModFinalizer <$> get+    20 -> THMsg <$> (AddForeignFilePath <$> get <*> get)+    21 -> THMsg <$> AddCorePlugin <$> get+    22 -> THMsg <$> ReifyType <$> get+    n -> error ("getTHMessage: unknown message " ++ show n)  putTHMessage :: THMessage a -> Put putTHMessage m = case m of@@ -297,14 +313,18 @@   ReifyModule a               -> putWord8 8  >> put a   ReifyConStrictness a        -> putWord8 9  >> put a   AddDependentFile a          -> putWord8 10 >> put a-  AddTopDecls a               -> putWord8 11 >> put a-  IsExtEnabled a              -> putWord8 12 >> put a-  ExtsEnabled                 -> putWord8 13-  StartRecover                -> putWord8 14-  EndRecover a                -> putWord8 15 >> put a-  RunTHDone                   -> putWord8 16-  AddModFinalizer a           -> putWord8 17 >> put a-  AddForeignFile lang a       -> putWord8 18 >> put lang >> put a+  AddTempFile a               -> putWord8 11 >> put a+  AddTopDecls a               -> putWord8 12 >> put a+  IsExtEnabled a              -> putWord8 13 >> put a+  ExtsEnabled                 -> putWord8 14+  StartRecover                -> putWord8 15+  EndRecover a                -> putWord8 16 >> put a+  FailIfErrs                  -> putWord8 17+  RunTHDone                   -> putWord8 18+  AddModFinalizer a           -> putWord8 19 >> put a+  AddForeignFilePath lang a   -> putWord8 20 >> put lang >> put a+  AddCorePlugin a             -> putWord8 21 >> put a+  ReifyType a                 -> putWord8 22 >> put a   data EvalOpts = EvalOpts@@ -384,17 +404,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@@ -422,6 +432,22 @@   } instance Show QState where show _ = "<QState>" +-- Orphan instances of Binary for Ptr / FunPtr by conversion to Word64.+-- This is to support Binary StgInfoTable which includes these.+instance Binary (Ptr a) where+  put p = put (fromIntegral (ptrToWordPtr p) :: Word64)+  get = (wordPtrToPtr . fromIntegral) <$> (get :: Get Word64)++instance Binary (FunPtr a) where+  put = put . castFunPtrToPtr+  get = castPtrToFunPtr <$> get++-- Binary instances to support the GetClosure message+instance Binary StgInfoTable+instance Binary ClosureType+instance Binary PrimType+instance Binary a => Binary (GenClosure a)+ data Msg = forall a . (Binary a, Show a) => Msg (Message a)  getMessage :: Get Msg@@ -462,7 +488,11 @@       31 -> Msg <$> return StartTH       32 -> Msg <$> (RunModFinalizers <$> get <*> get)       33 -> Msg <$> (AddSptEntry <$> get <*> get)-      _  -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)+      34 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)+      35 -> Msg <$> (GetClosure <$> get)+      36 -> Msg <$> (Seq <$> get)+      37 -> Msg <$> return RtsRevertCAFs+      _  -> error $ "Unknown Message code " ++ (show b)  putMessage :: Message a -> Put putMessage m = case m of@@ -501,6 +531,9 @@   RunModFinalizers a b        -> putWord8 32 >> put a >> put b   AddSptEntry a b             -> putWord8 33 >> put a >> put b   RunTH st q loc ty           -> putWord8 34 >> put st >> put q >> put loc >> put ty+  GetClosure a                -> putWord8 35 >> put a+  Seq a                       -> putWord8 36 >> put a+  RtsRevertCAFs               -> putWord8 37  -- ----------------------------------------------------------------------------- -- Reading/writing messages
GHCi/ObjLink.hs view
@@ -25,6 +25,7 @@   , findSystemLibrary   )  where +import Prelude -- See note [Why do we import Prelude here?] import GHCi.RemoteTypes import Control.Exception (throwIO, ErrorCall(..)) import Control.Monad    ( when )@@ -180,14 +181,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
GHCi/RemoteTypes.hs view
@@ -17,6 +17,7 @@   , unsafeForeignRefToRemoteRef, finalizeForeignRef   ) where +import Prelude -- See note [Why do we import Prelude here?] import Control.DeepSeq import Data.Word import Foreign hiding (newForeignPtr)@@ -30,14 +31,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))
GHCi/ResolvedBCO.hs view
@@ -1,78 +1,65 @@ {-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,-    BangPatterns #-}+    BangPatterns, CPP #-} module GHCi.ResolvedBCO   ( ResolvedBCO(..)   , ResolvedBCOPtr(..)+  , isLittleEndian   ) where +import Prelude -- See note [Why do we import Prelude here?] 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
GHCi/Run.hs view
@@ -12,6 +12,7 @@   ( run, redirectInterrupts   ) where +import Prelude -- See note [Why do we import Prelude here?] import GHCi.CreateBCO import GHCi.InfoTable import GHCi.FFI@@ -31,8 +32,9 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Unsafe as B import GHC.Exts+import GHC.Exts.Heap import GHC.Stack-import Foreign+import Foreign hiding (void) import Foreign.C import GHC.Conc.Sync import GHC.IO hiding ( bracket )@@ -42,9 +44,13 @@ -- ----------------------------------------------------------------------------- -- Implement messages +foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()+        -- Make it "safe", just in case+ run :: Message a -> IO a run m = case m of   InitLinker -> initObjLinker RetainCAFs+  RtsRevertCAFs -> rts_revertCAFs   LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str   LookupClosure str -> lookupClosure str   LoadDLL str -> loadDLL str@@ -86,6 +92,10 @@   MkConInfoTable ptrs nptrs tag ptrtag desc ->     toRemotePtr <$> mkConInfoTable ptrs nptrs tag ptrtag desc   StartTH -> startTH+  GetClosure ref -> do+    clos <- getClosureData =<< localRef ref+    mapM (\(Box x) -> mkRemoteRef (HValue x)) clos+  Seq ref -> tryEval (void $ evaluate =<< localRef ref)   _other -> error "GHCi.Run.run"  evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])@@ -298,7 +308,12 @@ resetStepFlag :: IO () resetStepFlag = poke stepFlag 0 -type BreakpointCallback = Int# -> Int# -> Bool -> HValue -> IO ()+type BreakpointCallback+     = Int#    -- the breakpoint index+    -> Int#    -- the module uniq+    -> Bool    -- exception?+    -> HValue  -- the AP_STACK, or exception+    -> IO ()  foreign import ccall "&rts_breakpoint_io_action"    breakPointIOAction :: Ptr (StablePtr BreakpointCallback)@@ -344,9 +359,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
GHCi/Signals.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE CPP #-} module GHCi.Signals (installSignalHandlers) where +import Prelude -- See note [Why do we import Prelude here?] import Control.Concurrent import Control.Exception import System.Mem.Weak  ( deRefWeak ) -#ifndef mingw32_HOST_OS+#if !defined(mingw32_HOST_OS) import System.Posix.Signals #endif
GHCi/StaticPtrTable.hs view
@@ -3,6 +3,7 @@  module GHCi.StaticPtrTable ( sptAddEntry ) where +import Prelude -- See note [Why do we import Prelude here?] import Data.Word import Foreign import GHC.Fingerprint
GHCi/TH.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,-    TupleSections, RecordWildCards, InstanceSigs #-}+    TupleSections, RecordWildCards, InstanceSigs, CPP #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}  -- |@@ -91,12 +91,14 @@     compiler/typecheck/TcSplice.hs -} +import Prelude -- See note [Why do we import Prelude here?] import GHCi.Message import GHCi.RemoteTypes import GHC.Serialized  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)@@ -104,6 +106,7 @@ import qualified Data.ByteString.Lazy as LB import Data.Data import Data.Dynamic+import Data.Either import Data.IORef import Data.Map (Map) import qualified Data.Map as M@@ -141,7 +144,9 @@     do (m', s')  <- runGHCiQ m s        (a,  s'') <- runGHCiQ (f m') s'        return (a, s'')+#if !MIN_VERSION_base(4,13,0)   fail = Fail.fail+#endif  instance Fail.MonadFail GHCiQ where   fail err  = GHCiQ $ \s -> throwIO (GHCiQException s err)@@ -160,21 +165,25 @@     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)    -- See Note [TH recover with -fexternal-interpreter] in TcSplice-  qRecover (GHCiQ h) (GHCiQ a) = GHCiQ $ \s -> (do+  qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do     remoteTHCall (qsPipe s) StartRecover-    (r, s') <- a s-    remoteTHCall (qsPipe s) (EndRecover False)-    return (r,s'))-      `catch`-       \GHCiQException{} -> remoteTHCall (qsPipe s) (EndRecover True) >> h s+    e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s+    remoteTHCall (qsPipe s) (EndRecover (isLeft e))+    case e of+      Left GHCiQException{} -> h s+      Right r -> return r   qLookupName isType occ = ghcCmd (LookupName isType occ)   qReify name = ghcCmd (Reify name)   qReifyFixity name = ghcCmd (ReifyFixity name)+  qReifyType name = ghcCmd (ReifyType name)   qReifyInstances name tys = ghcCmd (ReifyInstances name tys)   qReifyRoles name = ghcCmd (ReifyRoles name) @@ -190,12 +199,13 @@   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)+  qAddTempFile suffix = ghcCmd (AddTempFile suffix)   qAddTopDecls decls = ghcCmd (AddTopDecls decls)-  qAddForeignFile str lang = ghcCmd (AddForeignFile str lang)+  qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)   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@@ -256,7 +266,7 @@ runTHQ   :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a   -> IO ByteString-runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do+runTHQ pipe rstate mb_loc ghciq = do   qstateref <- localRef rstate   qstate <- readIORef qstateref   let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
GHCi/TH/Binary.hs view
@@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -8,14 +7,13 @@ -- This module is full of orphans, unfortunately module GHCi.TH.Binary () where +import Prelude -- See note [Why do we import Prelude here?] import Data.Binary import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as B import GHC.Serialized import qualified Language.Haskell.TH        as TH import qualified Language.Haskell.TH.Syntax as TH-#if !MIN_VERSION_base(4,10,0)-import Data.Typeable-#endif -- Put these in a separate module because they take ages to compile  instance Binary TH.Loc@@ -44,7 +42,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@@ -77,15 +74,9 @@     put (Serialized tyrep wds) = put tyrep >> put (B.pack wds)     get = Serialized <$> get <*> (B.unpack <$> get) --- Typeable and related instances live in binary since GHC 8.2-#if !MIN_VERSION_base(4,10,0)-instance Binary TyCon where-    put tc = put (tyConPackage tc) >> put (tyConModule tc) >> put (tyConName tc)-    get = mkTyCon3 <$> get <*> get <*> get--instance Binary TypeRep where-    put type_rep = put (splitTyConApp type_rep)-    get = do-        (ty_con, child_type_reps) <- get-        return (mkTyConApp ty_con child_type_reps)-#endif+instance Binary TH.Bytes where+   put (TH.Bytes ptr off sz) = put bs+      where bs = B.PS ptr (fromIntegral off) (fromIntegral sz)+   get = do+      B.PS ptr off sz <- get+      return (TH.Bytes ptr (fromIntegral off) (fromIntegral sz))
− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
SizedSeq.hs view
@@ -8,6 +8,7 @@   , sizeSS   ) where +import Prelude -- See note [Why do we import Prelude here?] import Control.DeepSeq import Data.Binary import Data.List
changelog.md view
@@ -2,14 +2,6 @@    * 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
ghci.cabal view
@@ -1,16 +1,17 @@+cabal-version:  >=1.10 name:           ghci-version:        8.2.2+version:        8.10.2+ license:        BSD3 license-file:   LICENSE category:       GHC maintainer:     ghc-devs@haskell.org-bug-reports:    https://ghc.haskell.org/trac/ghc/newticket+bug-reports:    https://gitlab.haskell.org/ghc/ghc/issues/new synopsis:       The library supporting GHC's interactive interpreter description:             This library offers interfaces which mediate interactions between the             @ghci@ interactive shell and @iserv@, GHC's out-of-process interpreter             backend.-cabal-version:  >=1.10 build-type:     Simple extra-source-files: changelog.md @@ -21,11 +22,12 @@  source-repository head     type:     git-    location: http://git.haskell.org/ghc.git+    location: https://gitlab.haskell.org/ghc/ghc.git     subdir:   libraries/ghci  library     default-language: Haskell2010+    default-extensions: NoImplicitPrelude     other-extensions:         BangPatterns         CPP@@ -44,7 +46,7 @@         UnboxedTuples      if flag(ghci)-        CPP-Options: -DGHCI+        CPP-Options: -DHAVE_INTERNAL_INTERPRETER         exposed-modules:             GHCi.Run             GHCi.CreateBCO@@ -52,8 +54,11 @@             GHCi.Signals             GHCi.TH +    include-dirs: +     exposed-modules:         GHCi.BreakArray+        GHCi.BinaryArray         GHCi.Message         GHCi.ResolvedBCO         GHCi.RemoteTypes@@ -65,15 +70,16 @@      Build-Depends:         array            == 0.5.*,-        base             >= 4.8 && < 4.11,+        base             >= 4.8 && < 4.15,         binary           == 0.8.*,         bytestring       == 0.10.*,-        containers       == 0.5.*,+        containers       >= 0.5 && < 0.7,         deepseq          == 1.4.*,         filepath         == 1.4.*,-        ghc-boot         == 8.2.2,-        ghc-boot-th      == 8.2.2,-        template-haskell == 2.12.*,+        ghc-boot         == 8.10.2,+        ghc-boot-th      == 8.10.2,+        ghc-heap         == 8.10.2,+        template-haskell == 2.16.*,         transformers     == 0.5.*      if !os(windows)