From 36467a7e8de0a08365442b69883e837331fd9c4b Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 26 Jan 2024 20:40:06 +0100 Subject: [PATCH 1/5] Fixed a typo in the readme file --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 9269d01..b61e291 100644 --- a/README.md +++ b/README.md @@ -17,6 +17,6 @@ used and how it works internally. `nothunks` will try to get source information from info tables. For that one needs to use `GHC` newer than `9.4` and compile the code with `-finfo-table-map`. More precise information will be available if -`-fdistinct-constructor-table` flag is used as well. We don't support this +`-fdistinct-constructor-tables` flag is used as well. We don't support this feature in `GHC-9.2` (although an earlier version of `whereFrom` is available in `base`). From a39a0566d1fbabceaa0d5d57125fe7f64c7a2636 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sat, 27 Jan 2024 12:26:54 +0100 Subject: [PATCH 2/5] ThunkInfo changes If using `whereFrom`, only show the location information of the thunk itself, not the stack. --- src/NoThunks/Class.hs | 89 ++++++++++++++++++++----------------- test/Test/NoThunks/Class.hs | 2 +- 2 files changed, 48 insertions(+), 43 deletions(-) diff --git a/src/NoThunks/Class.hs b/src/NoThunks/Class.hs index 264f628..35a60df 100644 --- a/src/NoThunks/Class.hs +++ b/src/NoThunks/Class.hs @@ -20,6 +20,7 @@ module NoThunks.Class ( NoThunks(..) , ThunkInfo(..) , Context + , Info , unsafeNoThunks -- * Helpers for defining instances , allNoThunks @@ -129,18 +130,19 @@ class NoThunks a where -- reports the /unexpected/ thunks. -- -- The default implementation of 'noThunks' checks that the argument is in - -- WHNF, and if so, adds the type into the context (using 'showTypeOf'), and - -- calls 'wNoThunks'. See 'ThunkInfo' for a detailed discussion of the type - -- context. + -- WHNF, and if so, adds the type into the context (using 'showTypeOf' or + -- 'whereFrom' if available), and calls 'wNoThunks'. See 'ThunkInfo' for + -- a detailed discussion of the type context. + -- -- -- See also discussion of caveats listed for 'checkContainsThunks'. noThunks :: Context -> a -> IO (Maybe ThunkInfo) noThunks ctxt x = do isThunk <- checkIsThunk x - c <- getThunkContext (showTypeOf (Proxy @a)) x - let ctxt' = c : ctxt + let ctxt' = showTypeOf (Proxy @a) : ctxt + thunkInfo <- getThunkInfo ctxt' x if isThunk - then return $ Just ThunkInfo { thunkContext = ctxt' } + then return $ Just thunkInfo else wNoThunks ctxt' x -- | Check that the argument is in normal form, assuming it is in WHNF. @@ -194,48 +196,51 @@ class NoThunks a where -- @Int@ which was a thunk. type Context = [String] +-- | Binding name, type and location information about the thunk, e.g. +-- +-- > fromModel :: Int @ test/Test/NoThunks/Class.hs:198:53-84 +-- +type Info = String + {------------------------------------------------------------------------------- Results of the check -------------------------------------------------------------------------------} -- | Information about unexpected thunks -- --- TODO: The ghc-debug work by Matthew Pickering includes some work that allows --- to get source spans from closures. If we could take advantage of that, we --- could not only show the type of the unexpected thunk, but also where it got --- allocated. -newtype ThunkInfo = ThunkInfo { - -- The @Context@ argument is intended to give a clue to add debugging. - -- For example, suppose we have something of type @(Int, [Int])@. The - -- various contexts we might get are - -- - -- > Context The thunk is.. - -- > --------------------------------------------------------------------- - -- > ["(,)"] the pair itself - -- > ["Int","(,)"] the Int in the pair - -- > ["List","(,)"] the [Int] in the pair - -- > ["Int","List","(,)"] an Int in the [Int] in the pair - -- - -- Note: prior to `ghc-9.6` a list was indicated by `[]`. - -- - -- Note: if compiled with `-finfo-table-map` (and - -- `-fdistinct-constructor-tables`) the context will contains source - -- location if available from the RTS. - thunkContext :: Context - } - deriving (Show) - -getThunkContext :: String -> a -> IO String -#if MIN_VERSION_base(4,18,0) -getThunkContext c a = maybe c infoProvContext <$> whereFrom a +-- ThunkInfo contains either precise `Info` about the thunk location +-- or `Context` to make it easier to debug space leaks. `Info` is available if +-- +-- * @GHC-9.4@ or newer is used, +-- * the code is compiled with @-finfo-table-map@ and is improved if +-- @-fdistinct-constructor-tables@ is used as well. +-- +-- The @Context@ argument is intended to give a clue to add debugging. +-- For example, suppose we have something of type @(Int, [Int])@. The +-- various contexts we might get are +-- +-- > Context The thunk is.. +-- > --------------------------------------------------------------------- +-- > ["(,)"] the pair itself +-- > ["Int","(,)"] the Int in the pair +-- > ["List","(,)"] the [Int] in the pair +-- > ["Int","List","(,)"] an Int in the [Int] in the pair +-- +-- Note: prior to `ghc-9.6` a list was indicated by `[]`. +newtype ThunkInfo = ThunkInfo { thunkInfo :: Either Context Info } + deriving Show -infoProvContext :: InfoProv -> String -infoProvContext InfoProv { ipSrcFile, ipSrcSpan, - ipLabel, ipTyDesc } = - ipLabel ++ " :: " ++ ipTyDesc - ++ " @ " ++ ipSrcFile ++ ":" ++ ipSrcSpan +getThunkInfo :: Context -> a -> IO ThunkInfo +#if MIN_VERSION_base(4,18,0) +getThunkInfo ctxt a = ThunkInfo . maybe (Left ctxt) (Right . fmt) <$> whereFrom a + where + fmt :: InfoProv -> Info + fmt InfoProv { ipSrcFile, ipSrcSpan, + ipLabel, ipTyDesc } = + ipLabel ++ " :: " ++ ipTyDesc + ++ " @ " ++ ipSrcFile ++ ":" ++ ipSrcSpan #else -getThunkContext c _ = return c +getThunkInfo ctxt _ = return (ThunkInfo (Left ctxt)) #endif @@ -384,9 +389,9 @@ instance KnownSymbol name => NoThunks (InspectHeapNamed name a) where inspectHeap :: Context -> a -> IO (Maybe ThunkInfo) inspectHeap ctxt x = do containsThunks <- checkContainsThunks x - c <- getThunkContext "..." x + thunkInfo <- getThunkInfo ("..." : ctxt) x return $ if containsThunks - then Just $ ThunkInfo { thunkContext = c : ctxt } + then Just thunkInfo else Nothing {------------------------------------------------------------------------------- diff --git a/test/Test/NoThunks/Class.hs b/test/Test/NoThunks/Class.hs index 64b7189..38af768 100644 --- a/test/Test/NoThunks/Class.hs +++ b/test/Test/NoThunks/Class.hs @@ -104,7 +104,7 @@ agreeOnNF mThunk mCtxt = isNothing mThunk == isNothing mCtxt -- | Check whether the model and the implementation agree on whether the value -- is in NF, and if not, what the context of the thunk is. agreeOnContext :: Maybe ThunkInfo -> Maybe [String] -> Bool -agreeOnContext mThunk mCtxt = (thunkContext <$> mThunk) == mCtxt +agreeOnContext mThunk mCtxt = (thunkInfo <$> mThunk) == (Left <$> mCtxt) {------------------------------------------------------------------------------- Infrastructure From 936527b0c3f11ba1adde2524ff96bbef1215da1c Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sat, 27 Jan 2024 12:52:18 +0100 Subject: [PATCH 3/5] tests: added sum tests --- test/Test/NoThunks/Class.hs | 39 +++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/test/Test/NoThunks/Class.hs b/test/Test/NoThunks/Class.hs index 38af768..24eeef6 100644 --- a/test/Test/NoThunks/Class.hs +++ b/test/Test/NoThunks/Class.hs @@ -66,12 +66,14 @@ tests = testGroup "NoThunks.Class" [ testProperty "IntNotNF" sanityCheckIntNotNF , testProperty "IntIsNF" sanityCheckIntIsNF , testProperty "Pair" sanityCheckPair + , testProperty "Sum" sanityCheckSum , testProperty "Fn" sanityCheckFn , testProperty "IO" sanityCheckIO ] , testGroup "InspectHeap" [ testProperty "Int" $ testWithModel agreeOnNF $ Proxy @(InspectHeap Int) , testProperty "IntInt" $ testWithModel agreeOnNF $ Proxy @(InspectHeap (Int, Int)) + , testProperty "SumInt" $ testWithModel agreeOnNF $ Proxy @(InspectHeap (Either Int Int)) , testProperty "ListInt" $ testWithModel agreeOnNF $ Proxy @(InspectHeap [Int]) , testProperty "IntListInt" $ testWithModel agreeOnNF $ Proxy @(InspectHeap (Int, [Int])) , testProperty "SeqInt" $ expectFailure $ testWithModel agreeOnNF $ Proxy @(InspectHeap (Seq Int)) @@ -79,6 +81,7 @@ tests = testGroup "NoThunks.Class" [ , testGroup "Model" [ testProperty "Int" $ testWithModel agreeOnContext $ Proxy @Int , testProperty "IntInt" $ testWithModel agreeOnContext $ Proxy @(Int, Int) + , testProperty "SumInt" $ testWithModel agreeOnContext $ Proxy @(Either Int Int) , testProperty "ListInt" $ testWithModel agreeOnContext $ Proxy @[Int] , testProperty "IntListInt" $ testWithModel agreeOnContext $ Proxy @(Int, [Int]) , testProperty "SeqInt" $ testWithModel agreeOnContext $ Proxy @(Seq Int) @@ -231,6 +234,35 @@ instance (FromModel a, FromModel b) => FromModel (a, b) where deriving instance (Show (Model a), Show (Model b)) => Show (Model (a, b)) +{------------------------------------------------------------------------------- + Sums +-------------------------------------------------------------------------------} + +instance (FromModel a, FromModel b) => FromModel (Either a b) where + data Model (Either a b) = + SumThunk (Model (Either a b)) + | LeftDefined (Model a) + | RightDefined (Model b) + + modelIsNF ctxt = \case + SumThunk _ -> NotWHNF ctxt' + LeftDefined a -> constrNF [modelIsNF ctxt' a] + RightDefined b -> constrNF [modelIsNF ctxt' b] + where + ctxt' = "Either" : ctxt + + fromModel (SumThunk p) k = fromModel p $ \p' -> k (if ack 3 3 > 0 then p' else p') + fromModel (LeftDefined a) k = fromModel a $ \a' -> k (Left a') + fromModel (RightDefined b) k = fromModel b $ \b' -> k (Right b') + + genModel = Gen.choice [ + LeftDefined <$> genModel + , RightDefined <$> genModel + , SumThunk <$> genModel + ] + +deriving instance (Show (Model a), Show (Model b)) => Show (Model (Either a b)) + {------------------------------------------------------------------------------- Lists -------------------------------------------------------------------------------} @@ -548,6 +580,13 @@ sanityCheckPair = checkNF False (\k -> k (if ack 3 3 > 0 then x else x)) x :: (Int, Bool) x = (0, True) +{-# NOINLINE sanityCheckSum #-} +sanityCheckSum :: Property +sanityCheckSum = checkNF False (\k -> k (if ack 3 3 > 0 then x else x)) + where + x :: Either Int Int + x = Right 0 + {-# NOINLINE sanityCheckFn #-} sanityCheckFn :: Property sanityCheckFn = checkNF False $ \k -> do From c35e02b28e1f3074ffa7d67963ea376844058afd Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sat, 27 Jan 2024 12:52:28 +0100 Subject: [PATCH 4/5] tests: renamed binding To reflect type variable name. --- test/Test/NoThunks/Class.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/Test/NoThunks/Class.hs b/test/Test/NoThunks/Class.hs index 24eeef6..bd98468 100644 --- a/test/Test/NoThunks/Class.hs +++ b/test/Test/NoThunks/Class.hs @@ -555,8 +555,8 @@ deriving instance Show (Model a) => Show (Model (InspectHeap a)) {-# NOINLINE checkNF #-} checkNF :: Bool -> ((a -> PropertyT IO ()) -> PropertyT IO ()) -> Property -checkNF expectedNF k = withTests 1 $ property $ k $ \x -> do - nf <- liftIO $ noThunks [] (InspectHeapNamed @"a" x) +checkNF expectedNF k = withTests 1 $ property $ k $ \a -> do + nf <- liftIO $ noThunks [] (InspectHeapNamed @"a" a) isNothing nf === expectedNF {-# NOINLINE sanityCheckIntNotNF #-} From 8a9ddb0a06d8f959bd343e9ef8f2427fe93b5f4a Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 26 Jan 2024 20:41:44 +0100 Subject: [PATCH 5/5] Bump version --- CHANGELOG.md | 3 ++- nothunks.cabal | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6829f3e..ad2786d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,11 @@ # Revision history for nothunks -## next version +## 0.2.0 -- 2024-01-27 * Use `whereFrom` to get source information, which is avialable when the source is compiled with `GHC-9.2` (or newer) and with `-finfo-table-map` (and even more accurate when `-fdistinct-constructor-table` is passed). + For that reason the `ThunkInfo` type has changed. * `NoThunks` instance for `Data.Tuple.Solo`. * `NoThunks` instances for `Data.Semigroup` and `Data.Monoid` newtype wrappers. diff --git a/nothunks.cabal b/nothunks.cabal index 2077c2b..a3a6788 100644 --- a/nothunks.cabal +++ b/nothunks.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: nothunks -version: 0.1.5 +version: 0.2.0 synopsis: Examine values for unexpected thunks description: Long lived application data typically should not contain any thunks. This library can be used to examine values for