diff --git a/GHCi/InfoTable.hsc b/GHCi/InfoTable.hsc --- a/GHCi/InfoTable.hsc +++ b/GHCi/InfoTable.hsc @@ -24,15 +24,16 @@ :: Int -- ptr words -> Int -- non-ptr words -> Int -- constr tag + -> Int -- pointer tag -> [Word8] -- con desc -> IO (Ptr StgInfoTable) -- resulting info table is allocated with allocateExec(), and -- should be freed with freeExec(). -mkConInfoTable ptr_words nonptr_words tag con_desc = +mkConInfoTable ptr_words nonptr_words tag ptrtag con_desc = castFunPtrToPtr <$> newExecConItbl itbl con_desc where - entry_addr = stg_interp_constr_entry + entry_addr = interpConstrEntry !! ptrtag code' = mkJumpToAddr entry_addr itbl = StgInfoTable { entry = if ghciTablesNextToCode @@ -283,8 +284,23 @@ #include "Rts.h" -- entry point for direct returns for created constr itbls -foreign import ccall "&stg_interp_constr_entry" - stg_interp_constr_entry :: EntryFunPtr +foreign import ccall "&stg_interp_constr1_entry" stg_interp_constr1_entry :: EntryFunPtr +foreign import ccall "&stg_interp_constr2_entry" stg_interp_constr2_entry :: EntryFunPtr +foreign import ccall "&stg_interp_constr3_entry" stg_interp_constr3_entry :: EntryFunPtr +foreign import ccall "&stg_interp_constr4_entry" stg_interp_constr4_entry :: EntryFunPtr +foreign import ccall "&stg_interp_constr5_entry" stg_interp_constr5_entry :: EntryFunPtr +foreign import ccall "&stg_interp_constr6_entry" stg_interp_constr6_entry :: EntryFunPtr +foreign import ccall "&stg_interp_constr7_entry" stg_interp_constr7_entry :: EntryFunPtr + +interpConstrEntry :: [EntryFunPtr] +interpConstrEntry = [ error "pointer tag 0" + , stg_interp_constr1_entry + , stg_interp_constr2_entry + , stg_interp_constr3_entry + , stg_interp_constr4_entry + , stg_interp_constr5_entry + , stg_interp_constr6_entry + , stg_interp_constr7_entry ] -- Ultra-minimalist version specially for constructors #if SIZEOF_VOID_P == 8 diff --git a/GHCi/Message.hs b/GHCi/Message.hs --- a/GHCi/Message.hs +++ b/GHCi/Message.hs @@ -85,6 +85,7 @@ :: Int -- ptr words -> Int -- non-ptr words -> Int -- constr tag + -> Int -- pointer tag -> [Word8] -- constructor desccription -> Message (RemotePtr StgInfoTable) @@ -161,9 +162,6 @@ -- | Start a new TH module, return a state token that should be StartTH :: Message (RemoteRef (IORef QState)) - -- | Run TH module finalizers, and free the HValueRef - FinishTH :: RemoteRef (IORef QState) -> Message () - -- | Evaluate a TH computation. -- -- Returns a ByteString, because we have to force the result @@ -190,7 +188,13 @@ ReifyModule :: TH.Module -> Message (THResult TH.ModuleInfo) ReifyConStrictness :: TH.Name -> Message (THResult [TH.DecidedStrictness]) + -- | Run the given mod finalizers. + RunModFinalizers :: RemoteRef (IORef QState) + -> [RemoteRef (TH.Q ())] + -> Message (THResult ()) + AddDependentFile :: FilePath -> Message (THResult ()) + AddModFinalizer :: RemoteRef (TH.Q ()) -> Message (THResult ()) AddTopDecls :: [TH.Dec] -> Message (THResult ()) IsExtEnabled :: Extension -> Message (THResult Bool) ExtsEnabled :: Message (THResult [Extension]) @@ -293,8 +297,6 @@ data QState = QState { qsMap :: Map TypeRep Dynamic -- ^ persistent data between splices in a module - , qsFinalizers :: [TH.Q ()] - -- ^ registered finalizers (in reverse order) , qsLocation :: Maybe TH.Loc -- ^ location for current splice, if any , qsPipe :: Pipe @@ -326,7 +328,7 @@ 15 -> Msg <$> MallocStrings <$> get 16 -> Msg <$> (PrepFFI <$> get <*> get <*> get) 17 -> Msg <$> FreeFFI <$> get - 18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get) + 18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get) 19 -> Msg <$> (EvalStmt <$> get <*> get) 20 -> Msg <$> (ResumeStmt <$> get <*> get) 21 -> Msg <$> (AbandonStmt <$> get) @@ -340,7 +342,7 @@ 29 -> Msg <$> (BreakpointStatus <$> get <*> get) 30 -> Msg <$> (GetBreakpointVar <$> get <*> get) 31 -> Msg <$> return StartTH - 32 -> Msg <$> FinishTH <$> get + -- 32 is missing 33 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get) 34 -> Msg <$> NewName <$> get 35 -> Msg <$> (Report <$> get <*> get) @@ -360,6 +362,8 @@ 49 -> Msg <$> EndRecover <$> get 50 -> Msg <$> return QDone 51 -> Msg <$> QException <$> get + 52 -> Msg <$> (RunModFinalizers <$> get <*> get) + 53 -> Msg <$> (AddModFinalizer <$> get) _ -> Msg <$> QFail <$> get putMessage :: Message a -> Put @@ -382,7 +386,7 @@ MallocStrings bss -> putWord8 15 >> put bss PrepFFI conv args res -> putWord8 16 >> put conv >> put args >> put res FreeFFI p -> putWord8 17 >> put p - MkConInfoTable p n t d -> putWord8 18 >> put p >> put n >> put t >> put d + MkConInfoTable p n t pt d -> putWord8 18 >> put p >> put n >> put t >> put pt >> put d EvalStmt opts val -> putWord8 19 >> put opts >> put val ResumeStmt opts val -> putWord8 20 >> put opts >> put val AbandonStmt val -> putWord8 21 >> put val @@ -396,7 +400,6 @@ BreakpointStatus arr ix -> putWord8 29 >> put arr >> put ix GetBreakpointVar a b -> putWord8 30 >> put a >> put b StartTH -> putWord8 31 - FinishTH val -> putWord8 32 >> put val RunTH st q loc ty -> putWord8 33 >> put st >> put q >> put loc >> put ty NewName a -> putWord8 34 >> put a Report a b -> putWord8 35 >> put a >> put b @@ -416,7 +419,9 @@ EndRecover a -> putWord8 49 >> put a QDone -> putWord8 50 QException a -> putWord8 51 >> put a - QFail a -> putWord8 52 >> put a + RunModFinalizers a b -> putWord8 52 >> put a >> put b + AddModFinalizer a -> putWord8 53 >> put a + QFail a -> putWord8 54 >> put a -- ----------------------------------------------------------------------------- -- Reading/writing messages diff --git a/GHCi/RemoteTypes.hs b/GHCi/RemoteTypes.hs --- a/GHCi/RemoteTypes.hs +++ b/GHCi/RemoteTypes.hs @@ -9,6 +9,7 @@ , unsafeForeignRefToRemoteRef, finalizeForeignRef ) where +import Control.DeepSeq import Data.Word import Foreign hiding (newForeignPtr) import Foreign.Concurrent @@ -41,6 +42,7 @@ deriving instance Show (RemotePtr a) deriving instance Binary (RemotePtr a) +deriving instance NFData (RemotePtr a) -- ----------------------------------------------------------------------------- -- HValueRef @@ -82,6 +84,9 @@ -- | An HValueRef with a finalizer newtype ForeignRef a = ForeignRef (ForeignPtr ()) + +instance NFData (ForeignRef a) where + rnf x = x `seq` () type ForeignHValue = ForeignRef HValue diff --git a/GHCi/Run.hs b/GHCi/Run.hs --- a/GHCi/Run.hs +++ b/GHCi/Run.hs @@ -80,8 +80,8 @@ MallocStrings bss -> mapM mkString0 bss PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res FreeFFI p -> freeForeignCallInfo (fromRemotePtr p) - MkConInfoTable ptrs nptrs tag desc -> - toRemotePtr <$> mkConInfoTable ptrs nptrs tag desc + MkConInfoTable ptrs nptrs tag ptrtag desc -> + toRemotePtr <$> mkConInfoTable ptrs nptrs tag ptrtag desc StartTH -> startTH _other -> error "GHCi.Run.run" diff --git a/GHCi/TH.hs b/GHCi/TH.hs --- a/GHCi/TH.hs +++ b/GHCi/TH.hs @@ -5,7 +5,12 @@ -- | -- Running TH splices -- -module GHCi.TH (startTH, finishTH, runTH, GHCiQException(..)) where +module GHCi.TH + ( startTH + , runModFinalizerRefs + , runTH + , GHCiQException(..) + ) where import GHCi.Message import GHCi.RemoteTypes @@ -30,14 +35,7 @@ import Unsafe.Coerce initQState :: Pipe -> QState -initQState p = QState M.empty [] Nothing p - -runModFinalizers :: GHCiQ () -runModFinalizers = go =<< getState - where - go s | (f:ff) <- qsFinalizers s = do - putState (s { qsFinalizers = ff}) >> TH.runQ f >> getState >>= go - go _ = return () +initQState p = QState M.empty Nothing p newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) } @@ -70,9 +68,6 @@ getState :: GHCiQ QState getState = GHCiQ $ \s -> return (s,s) -putState :: QState -> GHCiQ () -putState s = GHCiQ $ \_ -> return ((),s) - noLoc :: TH.Loc noLoc = TH.Loc "" "" "" (0,0) (0,0) @@ -116,8 +111,8 @@ qRunIO m = GHCiQ $ \s -> fmap (,s) m qAddDependentFile file = ghcCmd (AddDependentFile file) qAddTopDecls decls = ghcCmd (AddTopDecls decls) - qAddModFinalizer fin = GHCiQ $ \s -> - return ((), s { qsFinalizers = fin : qsFinalizers s }) + qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>= + ghcCmd . AddModFinalizer qGetQ = GHCiQ $ \s -> let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m @@ -132,11 +127,17 @@ r <- newIORef (initQState (error "startTH: no pipe")) mkRemoteRef r -finishTH :: Pipe -> RemoteRef (IORef QState) -> IO () -finishTH pipe rstate = do +-- | Runs the mod finalizers. +-- +-- The references must be created on the caller process. +runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState) + -> [RemoteRef (TH.Q ())] + -> IO () +runModFinalizerRefs pipe rstate qrefs = do + qs <- mapM localRef qrefs qstateref <- localRef rstate qstate <- readIORef qstateref - _ <- runGHCiQ runModFinalizers qstate { qsPipe = pipe } + _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe } return () runTH diff --git a/SizedSeq.hs b/SizedSeq.hs --- a/SizedSeq.hs +++ b/SizedSeq.hs @@ -8,11 +8,12 @@ , sizeSS ) where +import Control.DeepSeq import Data.Binary import Data.List import GHC.Generics -data SizedSeq a = SizedSeq !Word [a] +data SizedSeq a = SizedSeq {-# UNPACK #-} !Word [a] deriving (Generic, Show) instance Functor SizedSeq where @@ -25,6 +26,9 @@ traverse f (SizedSeq sz l) = SizedSeq sz . reverse <$> traverse f (reverse l) instance Binary a => Binary (SizedSeq a) + +instance NFData a => NFData (SizedSeq a) where + rnf (SizedSeq _ xs) = rnf xs emptySS :: SizedSeq a emptySS = SizedSeq 0 [] diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +## 8.0.2 *Jan 2017* + + * Bundled with GHC 8.0.2 + + * Tag pointers in interpreted constructors (#12523) + ## 8.0.1 *Feb 2016* * Bundled with GHC 8.0.1 diff --git a/ghci.cabal b/ghci.cabal --- a/ghci.cabal +++ b/ghci.cabal @@ -2,7 +2,7 @@ -- ../../configure. Make sure you are editing ghci.cabal.in, not ghci.cabal. name: ghci -version: 8.0.1 +version: 8.0.2 license: BSD3 license-file: LICENSE category: GHC @@ -64,7 +64,7 @@ containers == 0.5.*, deepseq == 1.4.*, filepath == 1.4.*, - ghc-boot == 8.0.1, + ghc-boot == 8.0.2, template-haskell == 2.11.*, transformers == 0.5.*