diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for breakpoint +## 0.1.2.0 -- 2022-11-18 +* `breakpoint` and `queryVars` include a `*result` binding in their output +* Fix a bug breaking Windows compatibility +* Fix a bug with overlapping breakpoints and timeouts + ## 0.1.1.1 -- 2022-11-02 * Support `IsString` version of string literals in `excludeVars` diff --git a/breakpoint.cabal b/breakpoint.cabal --- a/breakpoint.cabal +++ b/breakpoint.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: breakpoint -version: 0.1.1.1 +version: 0.1.2.0 synopsis: Set breakpoints using a GHC plugin diff --git a/src/Debug/Breakpoint.hs b/src/Debug/Breakpoint.hs --- a/src/Debug/Breakpoint.hs +++ b/src/Debug/Breakpoint.hs @@ -290,9 +290,9 @@ getSrcLocName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "getSrcLoc") excludeVarsName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "excludeVars") - let (group', _) = - runReader (runWriterT $ recurse group) - MkEnv { varSet = mempty, .. } + (group', _) <- + runReaderT (runWriterT $ recurse group) + MkEnv { varSet = mempty, .. } pure (gblEnv, group') @@ -337,7 +337,7 @@ . Ghc.ppr $ Ghc.locA' loc - captureVarsExpr = + captureVarsExpr mResultName = let mkTuple (Ghc.fromLexicalFastString -> varStr, n) = Ghc.mkLHsTupleExpr [ Ghc.nlHsLit . Ghc.mkHsString $ Ghc.unpackFS varStr @@ -349,46 +349,65 @@ mkList exprs = Ghc.noLocA' (Ghc.ExplicitList' Ghc.NoExtField exprs) + varSetWithResult + | Just resName <- mResultName = + M.insert (Ghc.mkLexicalFastString $ Ghc.mkFastString "*result") + resName + varSet + | otherwise = varSet + in Ghc.nlHsApp (Ghc.nlHsVar fromListName) . mkList - $ mkTuple <$> M.toList varSet + $ mkTuple <$> M.toList varSetWithResult - bpExpr = - Ghc.nlHsApp - (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitName) srcLocStringExpr) - captureVarsExpr + bpExpr = do + resultName <- Ghc.newName (Ghc.mkOccName Ghc.varName "_result_") + pure $ + Ghc.mkHsLam [Ghc.nlVarPat resultName] $ + Ghc.nlHsApp + (Ghc.nlHsApp + (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitName) srcLocStringExpr) + (captureVarsExpr $ Just resultName) + ) + (Ghc.nlHsVar resultName) bpMExpr = Ghc.nlHsApp (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitMName) srcLocStringExpr) - captureVarsExpr + $ captureVarsExpr Nothing bpIOExpr = Ghc.nlHsApp (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitIOName) srcLocStringExpr) - captureVarsExpr + $ captureVarsExpr Nothing queryVarsIOExpr = Ghc.nlHsApp (Ghc.nlHsApp (Ghc.nlHsVar runPromptIOName) srcLocStringExpr) - captureVarsExpr + $ captureVarsExpr Nothing - queryVarsExpr = - Ghc.nlHsApp - (Ghc.nlHsApp (Ghc.nlHsVar runPromptName) srcLocStringExpr) - captureVarsExpr + queryVarsExpr = do + resultName <- Ghc.newName (Ghc.mkOccName Ghc.varName "_result_") + pure $ + Ghc.mkHsLam [Ghc.nlVarPat resultName] $ + Ghc.nlHsApp + (Ghc.nlHsApp + (Ghc.nlHsApp (Ghc.nlHsVar runPromptName) srcLocStringExpr) + (captureVarsExpr $ Just resultName) + ) + (Ghc.nlHsVar resultName) queryVarsMExpr = Ghc.nlHsApp (Ghc.nlHsApp (Ghc.nlHsVar runPromptMName) srcLocStringExpr) - captureVarsExpr + $ captureVarsExpr Nothing if | captureVarsName == name -> do tell $ Any True - pure (Just $ Ghc.unLoc captureVarsExpr) + pure (Just . Ghc.unLoc $ captureVarsExpr Nothing) | breakpointName == name -> do tell $ Any True - pure (Just $ Ghc.unLoc bpExpr) + Just . Ghc.unLoc <$> lift (lift bpExpr) | breakpointMName == name -> do tell $ Any True @@ -404,7 +423,7 @@ | queryVarsName == name -> do tell $ Any True - pure (Just $ Ghc.unLoc queryVarsExpr) + Just . Ghc.unLoc <$> lift (lift queryVarsExpr) | queryVarsMName == name -> do tell $ Any True @@ -707,7 +726,7 @@ -------------------------------------------------------------------------------- -- The writer is for tracking if an inner expression contains the target name -type EnvReader = WriterT Any (Reader Env) +type EnvReader = WriterT Any (ReaderT Env Ghc.TcM) type VarSet = M.Map Ghc.LexicalFastString' Ghc.Name diff --git a/src/Debug/Breakpoint/TimerManager.hs b/src/Debug/Breakpoint/TimerManager.hs --- a/src/Debug/Breakpoint/TimerManager.hs +++ b/src/Debug/Breakpoint/TimerManager.hs @@ -3,21 +3,27 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} module Debug.Breakpoint.TimerManager - ( modifyTimeouts - , suspendTimeouts + ( suspendTimeouts ) where +#if defined(mingw32_HOST_OS) || !MIN_VERSION_ghc(9,2,0) +-- Since Windows has its own timeout manager internals, I'm choosing not to support it for now. + +suspendTimeouts :: IO a -> IO a +suspendTimeouts = id + +#else + import Control.Concurrent(rtsSupportsBoundThreads) import Control.Monad (when) import Data.Foldable (foldl') -import Data.IORef (atomicModifyIORef') +import Data.IORef import Data.Word (Word64) -#if MIN_VERSION_ghc(9,2,0) import qualified GHC.Clock as Clock -#endif import GHC.Event import Language.Haskell.TH import Language.Haskell.TH.Syntax +import System.IO.Unsafe -------------------------------------------------------------------------------- -- Hidden functions imported via TH @@ -112,42 +118,49 @@ modifyTimeouts f = -- This only works for the threaded RTS when rtsSupportsBoundThreads $ do -#if defined(mingw32_HOST_OS) - pure () - -- Windows has its own way of tracking delays +-- #if defined(mingw32_HOST_OS) +-- -- Windows has its own way of tracking delays -- let modifyDelay = \case -- Delay x y -> Delay (f x) y -- DelaySTM x y -> DelaySTM (f x) y -- atomicModifyIORef'_ pendingDelays (fmap $ modifyDelay f) -#else +-- #else mgr <- getSystemTimerManager editTimeouts mgr $ \pq -> let els = psqToList pq upd pq' k = psqAdjust f k pq' in foldl' upd pq (psqKey <$> els) -#endif -- | has the effect of suspending timeouts while an action is occurring. This -- is only used for GHC >= 9.2 because the semantics are too strange without -- the ability to freeze the runtime. suspendTimeouts :: IO a -> IO a -#if MIN_VERSION_ghc(9,2,0) suspendTimeouts action = do - let oneYear = 1000 * 1000000 * 60 * 60 * 24 * 365 - -- Add a large length of time to all timeouts so that they don't immediately - -- expire when blocking ends - modifyTimeouts (+ oneYear) - before <- Clock.getMonotonicTimeNSec - r <- action - after <- Clock.getMonotonicTimeNSec - let elapsed = after - before - -- Set timeouts back to where they were plus the length of time spent blocking - modifyTimeouts (subtract $ oneYear - elapsed) - -- NB: any timeouts registered right before the block or immediately afterwards - -- would result in strange behavior. Perhaps do an atomic modify of the IORef - -- holding the timeout queue that covers the whole transaction? - pure r -#else -suspendTimeouts = id + alreadySuspended <- readIORef timeoutsSuspended + -- Don't allow nested breakpoints to both modify timeouts + if alreadySuspended || not rtsSupportsBoundThreads + then action + else do + writeIORef timeoutsSuspended True + let oneYear = 1000 * 1000000 * 60 * 60 * 24 * 365 + -- Add a large length of time to all timeouts so that they don't immediately + -- expire when blocking ends + modifyTimeouts (+ oneYear) + before <- Clock.getMonotonicTimeNSec + r <- action + after <- Clock.getMonotonicTimeNSec + let elapsed = after - before + -- Set timeouts back to where they were plus the length of time spent blocking + modifyTimeouts (subtract $ oneYear - elapsed) + -- NB: any timeouts registered right before the block or immediately afterwards + -- would result in strange behavior. Perhaps do an atomic modify of the IORef + -- holding the timeout queue that covers the whole transaction? + writeIORef timeoutsSuspended False + pure r + +timeoutsSuspended :: IORef Bool +timeoutsSuspended = unsafePerformIO $ newIORef False +{-# NOINLINE timeoutsSuspended #-} + #endif