breakpoint 0.1.1.1 → 0.1.2.0
raw patch · 4 files changed
+86/−49 lines, 4 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Debug.Breakpoint.TimerManager: modifyTimeouts :: (Word64 -> Word64) -> IO ()
Files
- CHANGELOG.md +5/−0
- breakpoint.cabal +1/−1
- src/Debug/Breakpoint.hs +40/−21
- src/Debug/Breakpoint/TimerManager.hs +40/−27
CHANGELOG.md view
@@ -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`
breakpoint.cabal view
@@ -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
src/Debug/Breakpoint.hs view
@@ -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
src/Debug/Breakpoint/TimerManager.hs view
@@ -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