Teo Camarasu pushed to branch wip/T27022 at Glasgow Haskell Compiler / GHC

Commits:

5 changed files:

Changes:

  • changelog.d/T27022
    1 
    +section: compiler
    2 
    +synopsis: Fix a divergence in the interaction between ``recover`` and ``putQ`` between the internal and external interpreter
    3 
    +description: The ``recover`` method in TemplateHaskell now behaves the same
    4 
    +  with the internal and external interpreter.
    5 
    +  In the past, when an error was encountered in a computation in a ``recover`` block,
    6 
    +  the external interpreter would discard any state changes from ``putQ``,
    7 
    +  whereas the internal interpreter would not.
    8 
    +  This was a long-standing error in the implementation of the external interpreter.
    9 
    +  Both now keep state changes from ``putQ`` in ``recover`` blocks.
    10 
    +mrs: !15994
    11 
    +issues: #27022

  • libraries/ghci/GHCi/TH.hs
    ... ... @@ -119,7 +119,7 @@ initQState :: Pipe -> QState
    119 119 
     initQState p = QState M.empty Nothing p
    120 120
    121 121 
     -- | The monad in which we run TH computations on the server
    122 
    -newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }
    122 
    +newtype GHCiQ a = GHCiQ { runGHCiQ :: IORef QState -> IO a }
    123 123
    124 124 
     -- | The exception thrown by "fail" in the GHCiQ monad
    125 125 
     data GHCiQException = GHCiQException QState String
    ... ... @@ -128,52 +128,54 @@ data GHCiQException = GHCiQException QState String
    128 128 
     instance Exception GHCiQException
    129 129
    130 130 
     instance Functor GHCiQ where
    131 
    -  fmap f (GHCiQ s) = GHCiQ $ fmap (\(x,s') -> (f x,s')) . s
    131 
    +  fmap f (GHCiQ m) = GHCiQ $ fmap f . m
    132 132
    133 133 
     instance Applicative GHCiQ where
    134 134 
       f <*> a = GHCiQ $ \s ->
    135 
    -    do (f',s')  <- runGHCiQ f s
    136 
    -       (a',s'') <- runGHCiQ a s'
    137 
    -       return (f' a', s'')
    138 
    -  pure x = GHCiQ (\s -> return (x,s))
    135 
    +    do f'  <- runGHCiQ f s
    136 
    +       a' <- runGHCiQ a s
    137 
    +       return $ f' a'
    138 
    +  pure x = GHCiQ $ \_ -> return x
    139 139
    140 140 
     instance Monad GHCiQ where
    141 141 
       m >>= f = GHCiQ $ \s ->
    142 
    -    do (m', s')  <- runGHCiQ m s
    143 
    -       (a,  s'') <- runGHCiQ (f m') s'
    144 
    -       return (a, s'')
    142 
    +    do m'  <- runGHCiQ m s
    143 
    +       a <- runGHCiQ (f m') s
    144 
    +       return a
    145 145
    146 146 
     instance MonadFail GHCiQ where
    147 
    -  fail err  = GHCiQ $ \s -> throwIO (GHCiQException s err)
    147 
    +  fail err  = GHCiQ $ \sRef -> readIORef sRef >>= \s -> throwIO (GHCiQException s err)
    148 148
    149 149 
     getState :: GHCiQ QState
    150 
    -getState = GHCiQ $ \s -> return (s,s)
    150 
    +getState = GHCiQ $ \sRef -> readIORef sRef
    151 151
    152 152 
     noLoc :: TH.Loc
    153 153 
     noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)
    154 154
    155 155 
     -- | Send a 'THMessage' to GHC and return the result.
    156 156 
     ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a
    157 
    -ghcCmd m = GHCiQ $ \s -> do
    157 
    +ghcCmd m = GHCiQ $ \sRef -> do
    158 
    +  s <- readIORef sRef
    158 159 
       r <- remoteTHCall (qsPipe s) m
    159 160 
       case r of
    160 161 
         THException str -> throwIO (GHCiQException s str)
    161 
    -    THComplete res -> return (res, s)
    162 
    +    THComplete res -> return res
    162 163
    163 164 
     instance MonadIO GHCiQ where
    164 
    -  liftIO m = GHCiQ $ \s -> fmap (,s) m
    165 
    +  liftIO m = GHCiQ $ \_ -> m
    165 166
    166 167 
     instance TH.Quasi GHCiQ where
    167 168 
       qNewName str = ghcCmd (NewName str)
    168 169 
       qReport isError msg = ghcCmd (Report isError msg)
    169 170
    170 171 
       -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
    171 
    -  qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do
    172 
    +  qRecover (GHCiQ h) a = GHCiQ $ \sRef -> mask $ \unmask -> do
    173 
    +    s <- readIORef sRef
    172 174 
         remoteTHCall (qsPipe s) StartRecover
    173 
    -    e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s
    175 
    +    e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) sRef
    174 176 
         remoteTHCall (qsPipe s) (EndRecover (isLeft e))
    175 177 
         case e of
    176 
    -      Left GHCiQException{} -> h s
    178 
    +      Left GHCiQException{} -> h sRef
    177 179 
           Right r -> return r
    178 180 
       qLookupName isType occ = ghcCmd (LookupName isType occ)
    179 181 
       qReify name = ghcCmd (Reify name)
    ... ... @@ -200,15 +202,16 @@ instance TH.Quasi GHCiQ where
    200 202 
       qAddTempFile suffix = ghcCmd (AddTempFile suffix)
    201 203 
       qAddTopDecls decls = ghcCmd (AddTopDecls decls)
    202 204 
       qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
    203 
    -  qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
    205 
    +  qAddModFinalizer fin = GHCiQ (\_ -> mkRemoteRef fin) >>=
    204 206 
                              ghcCmd . AddModFinalizer
    205 207 
       qAddCorePlugin str = ghcCmd (AddCorePlugin str)
    206 
    -  qGetQ = GHCiQ $ \s ->
    208 
    +  qGetQ = do
    209 
    +    s <- getState
    207 210 
         let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
    208 211 
             lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
    209 
    -    in return (lookup (qsMap s), s)
    210 
    -  qPutQ k = GHCiQ $ \s ->
    211 
    -    return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
    212 
    +    return $ lookup (qsMap s)
    213 
    +  qPutQ k = GHCiQ $ \sRef ->
    214 
    +    modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
    212 215 
       qIsExtEnabled x = ghcCmd (IsExtEnabled x)
    213 216 
       qExtsEnabled = ghcCmd ExtsEnabled
    214 217 
       qPutDoc l s = ghcCmd (PutDoc l s)
    ... ... @@ -231,7 +234,8 @@ runModFinalizerRefs pipe rstate qrefs = do
    231 234 
       qs <- mapM localRef qrefs
    232 235 
       qstateref <- localRef rstate
    233 236 
       qstate <- readIORef qstateref
    234 
    -  _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }
    237 
    +  qstate' <- newIORef $ qstate { qsPipe = pipe }
    238 
    +  _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate'
    235 239 
       return ()
    236 240
    237 241 
     -- | The implementation of the 'RunTH' message
    ... ... @@ -267,8 +271,6 @@ runTHQ
    267 271 
       -> IO ByteString
    268 272 
     runTHQ pipe rstate mb_loc ghciq = do
    269 273 
       qstateref <- localRef rstate
    270 
    -  qstate <- readIORef qstateref
    271 
    -  let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
    272 
    -  (r,new_state) <- runGHCiQ (TH.runQ ghciq) st
    273 
    -  writeIORef qstateref new_state
    274 
    +  modifyIORef' qstateref (\qstate -> qstate { qsLocation = mb_loc, qsPipe = pipe })
    275 
    +  r <- runGHCiQ (TH.runQ ghciq) qstateref
    274 276 
       return $! LB.toStrict (runPut (put r))

  • testsuite/tests/th/T27022.hs
    1 
    +{-# LANGUAGE TemplateHaskell #-}
    2 
    +-- | This tests the behaviour of TH's recover method.
    3 
    +-- It should behave the same in the internal and external interperter.
    4 
    +-- In the past, they have diverged, and the external interpreter would roll back the state of putQ/getQ whereas the internal interpreter would not.
    5 
    +module Main where
    6 
    +
    7 
    +import Language.Haskell.TH.Syntax
    8 
    +main = print $(putQ "0" >> recover (pure ()) (putQ "42" >> fail "oops")  >> getQ @String >>= lift )

  • testsuite/tests/th/T27022.stdout
    1 
    +Just "42"

  • testsuite/tests/th/all.T
    ... ... @@ -650,3 +650,4 @@ test('GadtConSigs_th_dump1', normal, compile, ['-v0 -ddump-splices -dsuppress-un
    650 650 
     test('T26099', normal, compile_fail, [''])
    651 651 
     test('T8306_th', only_ways(['ghci']), ghci_script, ['T8306_th.script'])
    652 652 
     test('T26862_th', only_ways(['ghci']), ghci_script, ['T26862_th.script'])
    653 
    +test('T27022', normal, compile_and_run, [''])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help