diff --git a/GHCi/BreakArray.hs b/GHCi/BreakArray.hs --- a/GHCi/BreakArray.hs +++ b/GHCi/BreakArray.hs @@ -19,17 +19,14 @@ 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 @@ -116,6 +113,3 @@ readBreakArray :: BreakArray -> Int -> IO Word8 readBreakArray (BA array) (I# i) = readBA# array i -#else -data BreakArray -#endif diff --git a/GHCi/InfoTable.hsc b/GHCi/InfoTable.hsc --- a/GHCi/InfoTable.hsc +++ b/GHCi/InfoTable.hsc @@ -10,28 +10,25 @@ -- module GHCi.InfoTable ( -#ifdef GHCI mkConInfoTable -#endif ) where import Prelude -- See note [Why do we import Prelude here?] -#ifdef GHCI import Foreign import Foreign.C import GHC.Ptr import GHC.Exts import GHC.Exts.Heap -#endif +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. @@ -40,7 +37,7 @@ -> 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(). @@ -79,6 +76,7 @@ | ArchARM64 | ArchPPC64 | ArchPPC64LE + | ArchS390X | ArchUnknown deriving Show @@ -102,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 @@ -271,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 @@ -344,10 +358,10 @@ Right xs -> sizeOf (head xs) * length xs -- Note: Must return proper pointer for use in a closure -newExecConItbl :: StgInfoTable -> [Word8] -> IO (FunPtr ()) +newExecConItbl :: StgInfoTable -> ByteString -> IO (FunPtr ()) newExecConItbl obj con_desc = alloca $ \pcode -> do - let lcon_desc = length con_desc + 1{- null terminator -} + 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) @@ -360,7 +374,10 @@ 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)) @@ -382,4 +399,3 @@ conInfoTableSizeB :: Int conInfoTableSizeB = wORD_SIZE + itblSize -#endif /* GHCI */ diff --git a/GHCi/Message.hs b/GHCi/Message.hs --- a/GHCi/Message.hs +++ b/GHCi/Message.hs @@ -25,7 +25,7 @@ import Prelude -- See note [Why do we import Prelude here?] import GHCi.RemoteTypes import GHCi.FFI -import GHCi.TH.Binary () +import GHCi.TH.Binary () -- For Binary instances import GHCi.BreakArray import GHC.LanguageExtensions @@ -61,6 +61,7 @@ data Message a where -- | Exit the iserv process Shutdown :: Message () + RtsRevertCAFs :: Message () -- RTS Linker ------------------------------------------- @@ -107,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 @@ -241,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 @@ -294,7 +296,9 @@ 18 -> return (THMsg RunTHDone) 19 -> THMsg <$> AddModFinalizer <$> get 20 -> THMsg <$> (AddForeignFilePath <$> get <*> get) - _ -> THMsg <$> AddCorePlugin <$> 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 @@ -320,6 +324,7 @@ 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 @@ -485,7 +490,9 @@ 33 -> Msg <$> (AddSptEntry <$> get <*> get) 34 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get) 35 -> Msg <$> (GetClosure <$> get) - _ -> Msg <$> (Seq <$> get) + 36 -> Msg <$> (Seq <$> get) + 37 -> Msg <$> return RtsRevertCAFs + _ -> error $ "Unknown Message code " ++ (show b) putMessage :: Message a -> Put putMessage m = case m of @@ -526,6 +533,7 @@ 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 diff --git a/GHCi/Run.hs b/GHCi/Run.hs --- a/GHCi/Run.hs +++ b/GHCi/Run.hs @@ -44,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 diff --git a/GHCi/TH.hs b/GHCi/TH.hs --- a/GHCi/TH.hs +++ b/GHCi/TH.hs @@ -183,6 +183,7 @@ 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) @@ -265,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 } diff --git a/GHCi/TH/Binary.hs b/GHCi/TH/Binary.hs --- a/GHCi/TH/Binary.hs +++ b/GHCi/TH/Binary.hs @@ -10,6 +10,7 @@ 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 @@ -72,3 +73,10 @@ instance Binary Serialized where put (Serialized tyrep wds) = put tyrep >> put (B.pack wds) get = Serialized <$> get <*> (B.unpack <$> get) + +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)) diff --git a/ghci.cabal b/ghci.cabal --- a/ghci.cabal +++ b/ghci.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: ghci -version: 8.8.3 +version: 8.10.1 license: BSD3 license-file: LICENSE @@ -46,7 +46,7 @@ UnboxedTuples if flag(ghci) - CPP-Options: -DGHCI + CPP-Options: -DHAVE_INTERNAL_INTERPRETER exposed-modules: GHCi.Run GHCi.CreateBCO @@ -70,16 +70,16 @@ Build-Depends: array == 0.5.*, - base >= 4.8 && < 4.14, + base >= 4.8 && < 4.15, binary == 0.8.*, bytestring == 0.10.*, containers >= 0.5 && < 0.7, deepseq == 1.4.*, filepath == 1.4.*, - ghc-boot == 8.8.3, - ghc-boot-th == 8.8.3, - ghc-heap == 8.8.3, - template-haskell == 2.15.*, + ghc-boot == 8.10.1, + ghc-boot-th == 8.10.1, + ghc-heap == 8.10.1, + template-haskell == 2.16.*, transformers == 0.5.* if !os(windows)