Teo Camarasu pushed to branch wip/T27022 at Glasgow Haskell Compiler / GHC Commits: 7028353e by Teo Camarasu at 2026-05-02T12:47:08+01:00 ghci/TH: refactor to use IORef QState This is a pure refactor and shouldn't modify semantics at all - - - - - 2f6811db by Teo Camarasu at 2026-05-02T14:07:04+01:00 iserv: recover/getQ/putQ should behave same as internal interpreter The internal and external interpreter should behave the same when handling `recover`, the exeception recovery method of Q. In practice, they diverge. In case of failure, the internal interpreter only restores error message state to before the computation, wheras the external interperter restores error message state *and* the state of putQ/getQ. As far as I can tell this is a simple mistake in the implementation. Note [TH recover with -fexternal-interpreter] describes the correct behaviour but the implementation doesn't mirror this. This change restores the correct behaviour by keeping the effects of putQ in the erroring computation. This is a breaking change since it modifies the behaviour of programs that rely on recover ignoring putQ from failling computations when used with the external interpreter. Although I highly doubt anyone relies on this behaviour. This divergence was first introduced in d00c308633fe7d216d31a1087e00e63532d87d6d. As far as I can tell this was unintentional and tha commit was trying to solve a different bug. Resolves #27022 - - - - - 5 changed files: - + changelog.d/T27022 - libraries/ghci/GHCi/TH.hs - + testsuite/tests/th/T27022.hs - + testsuite/tests/th/T27022.stdout - testsuite/tests/th/all.T Changes: ===================================== changelog.d/T27022 ===================================== @@ -0,0 +1,11 @@ +section: compiler +synopsis: Fix a divergence in the interaction between ``recover`` and ``putQ`` between the internal and external interpreter +description: The ``recover`` method in TemplateHaskell now behaves the same + with the internal and external interpreter. + In the past, when an error was encountered in a computation in a ``recover`` block, + the external interpreter would discard any state changes from ``putQ``, + whereas the internal interpreter would not. + This was a long-standing error in the implementation of the external interpreter. + Both now keep state changes from ``putQ`` in ``recover`` blocks. +mrs: !15994 +issues: #27022 ===================================== libraries/ghci/GHCi/TH.hs ===================================== @@ -119,7 +119,7 @@ initQState :: Pipe -> QState initQState p = QState M.empty Nothing p -- | The monad in which we run TH computations on the server -newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) } +newtype GHCiQ a = GHCiQ { runGHCiQ :: IORef QState -> IO a } -- | The exception thrown by "fail" in the GHCiQ monad data GHCiQException = GHCiQException QState String @@ -128,52 +128,54 @@ data GHCiQException = GHCiQException QState String instance Exception GHCiQException instance Functor GHCiQ where - fmap f (GHCiQ s) = GHCiQ $ fmap (\(x,s') -> (f x,s')) . s + fmap f (GHCiQ m) = GHCiQ $ fmap f . m instance Applicative GHCiQ where f <*> a = GHCiQ $ \s -> - do (f',s') <- runGHCiQ f s - (a',s'') <- runGHCiQ a s' - return (f' a', s'') - pure x = GHCiQ (\s -> return (x,s)) + do f' <- runGHCiQ f s + a' <- runGHCiQ a s + return $ f' a' + pure x = GHCiQ $ \_ -> return x instance Monad GHCiQ where m >>= f = GHCiQ $ \s -> - do (m', s') <- runGHCiQ m s - (a, s'') <- runGHCiQ (f m') s' - return (a, s'') + do m' <- runGHCiQ m s + a <- runGHCiQ (f m') s + return a instance MonadFail GHCiQ where - fail err = GHCiQ $ \s -> throwIO (GHCiQException s err) + fail err = GHCiQ $ \sRef -> readIORef sRef >>= \s -> throwIO (GHCiQException s err) getState :: GHCiQ QState -getState = GHCiQ $ \s -> return (s,s) +getState = GHCiQ $ \sRef -> readIORef sRef noLoc :: TH.Loc noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0) -- | Send a 'THMessage' to GHC and return the result. ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a -ghcCmd m = GHCiQ $ \s -> do +ghcCmd m = GHCiQ $ \sRef -> do + s <- readIORef sRef r <- remoteTHCall (qsPipe s) m case r of THException str -> throwIO (GHCiQException s str) - THComplete res -> return (res, s) + THComplete res -> return res instance MonadIO GHCiQ where - liftIO m = GHCiQ $ \s -> fmap (,s) m + liftIO m = GHCiQ $ \_ -> 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 GHC.Tc.Gen.Splice - qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do + qRecover (GHCiQ h) a = GHCiQ $ \sRef -> mask $ \unmask -> do + s <- readIORef sRef remoteTHCall (qsPipe s) StartRecover - e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s + e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) sRef remoteTHCall (qsPipe s) (EndRecover (isLeft e)) case e of - Left GHCiQException{} -> h s + Left GHCiQException{} -> h sRef Right r -> return r qLookupName isType occ = ghcCmd (LookupName isType occ) qReify name = ghcCmd (Reify name) @@ -200,15 +202,16 @@ instance TH.Quasi GHCiQ where qAddTempFile suffix = ghcCmd (AddTempFile suffix) qAddTopDecls decls = ghcCmd (AddTopDecls decls) qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp) - qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>= + qAddModFinalizer fin = GHCiQ (\_ -> mkRemoteRef fin) >>= ghcCmd . AddModFinalizer qAddCorePlugin str = ghcCmd (AddCorePlugin str) - qGetQ = GHCiQ $ \s -> + qGetQ = do + s <- getState let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m - in return (lookup (qsMap s), s) - qPutQ k = GHCiQ $ \s -> - return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) }) + return $ lookup (qsMap s) + qPutQ k = GHCiQ $ \sRef -> + modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) }) qIsExtEnabled x = ghcCmd (IsExtEnabled x) qExtsEnabled = ghcCmd ExtsEnabled qPutDoc l s = ghcCmd (PutDoc l s) @@ -231,7 +234,8 @@ runModFinalizerRefs pipe rstate qrefs = do qs <- mapM localRef qrefs qstateref <- localRef rstate qstate <- readIORef qstateref - _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe } + qstate' <- newIORef $ qstate { qsPipe = pipe } + _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate' return () -- | The implementation of the 'RunTH' message @@ -267,8 +271,6 @@ runTHQ -> IO ByteString runTHQ pipe rstate mb_loc ghciq = do qstateref <- localRef rstate - qstate <- readIORef qstateref - let st = qstate { qsLocation = mb_loc, qsPipe = pipe } - (r,new_state) <- runGHCiQ (TH.runQ ghciq) st - writeIORef qstateref new_state + modifyIORef' qstateref (\qstate -> qstate { qsLocation = mb_loc, qsPipe = pipe }) + r <- runGHCiQ (TH.runQ ghciq) qstateref return $! LB.toStrict (runPut (put r)) ===================================== testsuite/tests/th/T27022.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | This tests the behaviour of TH's recover method. +-- It should behave the same in the internal and external interperter. +-- In the past, they have diverged, and the external interpreter would roll back the state of putQ/getQ whereas the internal interpreter would not. +module Main where + +import Language.Haskell.TH.Syntax +main = print $(putQ "0" >> recover (pure ()) (putQ "42" >> fail "oops") >> getQ @String >>= lift ) ===================================== testsuite/tests/th/T27022.stdout ===================================== @@ -0,0 +1 @@ +Just "42" ===================================== testsuite/tests/th/all.T ===================================== @@ -650,3 +650,4 @@ test('GadtConSigs_th_dump1', normal, compile, ['-v0 -ddump-splices -dsuppress-un test('T26099', normal, compile_fail, ['']) test('T8306_th', only_ways(['ghci']), ghci_script, ['T8306_th.script']) test('T26862_th', only_ways(['ghci']), ghci_script, ['T26862_th.script']) +test('T27022', normal, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ab0e7b306f6b009845c8f6a7f05a24f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ab0e7b306f6b009845c8f6a7f05a24f... You're receiving this email because of your account on gitlab.haskell.org.