diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,13 @@ # 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.4` (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. ## 0.1.5 -- 2023-10-29 diff --git a/NOTICE b/NOTICE --- a/NOTICE +++ b/NOTICE @@ -1,4 +1,4 @@ -Copyright 2018-2023 Input Output Global Inc (IOG) +Copyright 2018-2024 Input Output Global Inc (IOG) Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/nothunks.cabal b/nothunks.cabal --- 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 @@ -13,10 +13,10 @@ bug-reports: https://github.com/input-output-hk/nothunks author: IOG maintainer: Marcin Szamotulski -copyright: 2018-2023 Input Output Global Inc (IOG) +copyright: 2018-2024 Input Output Global Inc (IOG) category: Development extra-doc-files: CHANGELOG.md -tested-with: GHC== { 8.10.7, 9.0.2, 9.2.5, 9.4.4, 9.6.1 } +tested-with: GHC == {8.10, 9.0, 9.2, 9.4, 9.6, 9.8} source-repository head type: git @@ -41,7 +41,7 @@ exposed-modules: NoThunks.Class build-depends: base >= 4.12 && < 5 - , containers >= 0.5 && < 0.7 + , containers >= 0.5 && < 0.8 , stm >= 2.5 && < 2.6 , time >= 1.5 && < 1.13 diff --git a/src/NoThunks/Class.hs b/src/NoThunks/Class.hs --- a/src/NoThunks/Class.hs +++ b/src/NoThunks/Class.hs @@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -19,6 +20,7 @@ NoThunks(..) , ThunkInfo(..) , Context + , Info , unsafeNoThunks -- * Helpers for defining instances , allNoThunks @@ -58,6 +60,9 @@ import Data.Sequence (Seq) import Data.Set (Set) import Data.Time +#if MIN_VERSION_base(4,16,0) +import Data.Tuple (Solo (..)) +#endif import Data.Void (Void) import Data.Word import GHC.Stack @@ -66,12 +71,18 @@ import Numeric.Natural #endif +#if MIN_VERSION_base(4,18,0) +import GHC.InfoProv +#endif + import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.STM.TVar as TVar import qualified Data.IntMap as IntMap import qualified Data.IORef as IORef import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.Monoid as Monoid +import qualified Data.Semigroup as Semigroup #ifdef MIN_VERSION_bytestring import Data.ByteString.Short (ShortByteString) @@ -119,20 +130,20 @@ -- 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 + 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 - where - ctxt' :: Context - ctxt' = showTypeOf (Proxy @a) : ctxt -- | Check that the argument is in normal form, assuming it is in WHNF. -- @@ -185,33 +196,54 @@ -- @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 `[]`. - thunkContext :: Context - } - deriving (Show) +-- 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 +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 +getThunkInfo ctxt _ = return (ThunkInfo (Left ctxt)) +#endif + + {-# NOINLINE unsafeNoThunks #-} -- | Call 'noThunks' in a pure context (relies on 'unsafePerformIO'). unsafeNoThunks :: NoThunks a => a -> Maybe ThunkInfo @@ -357,8 +389,9 @@ inspectHeap :: Context -> a -> IO (Maybe ThunkInfo) inspectHeap ctxt x = do containsThunks <- checkContainsThunks x + thunkInfo <- getThunkInfo ("..." : ctxt) x return $ if containsThunks - then Just $ ThunkInfo { thunkContext = "..." : ctxt } + then Just thunkInfo else Nothing {------------------------------------------------------------------------------- @@ -381,7 +414,7 @@ instance GWNoThunks a f => GWNoThunks a (C1 c f) where gwNoThunks a ctxt (M1 fp) = gwNoThunks a ctxt fp -instance GWNoThunks a f => GWNoThunks a (S1 ('MetaSel ('Nothing) su ss ds) f) where +instance GWNoThunks a f => GWNoThunks a (S1 ('MetaSel 'Nothing su ss ds) f) where gwNoThunks a ctxt (M1 fp) = gwNoThunks a ctxt fp instance (GWNoThunks a f, GWNoThunks a g) => GWNoThunks a (f :*: g) where @@ -478,6 +511,45 @@ deriving via OnlyCheckWhnf Word16 instance NoThunks Word16 deriving via OnlyCheckWhnf Word32 instance NoThunks Word32 deriving via OnlyCheckWhnf Word64 instance NoThunks Word64 + +{------------------------------------------------------------------------------- + Semigroups +-------------------------------------------------------------------------------} + +deriving via a instance NoThunks a => NoThunks (Semigroup.Min a) +deriving via a instance NoThunks a => NoThunks (Semigroup.Max a) +deriving via a instance NoThunks a => NoThunks (Semigroup.First a) +deriving via a instance NoThunks a => NoThunks (Semigroup.Last a) +deriving via a instance NoThunks a => NoThunks (Semigroup.Dual a) +deriving via Bool instance NoThunks Semigroup.All +deriving via Bool instance NoThunks Semigroup.Any +deriving via a instance NoThunks a => NoThunks (Semigroup.Sum a) +deriving via a instance NoThunks a => NoThunks (Semigroup.Product a) +deriving via a instance NoThunks a => NoThunks (Semigroup.WrappedMonoid a) +instance (NoThunks a, NoThunks b) => NoThunks (Semigroup.Arg a b) + +{------------------------------------------------------------------------------- + Monoids +-------------------------------------------------------------------------------} + +deriving via (Maybe a) instance NoThunks a => NoThunks (Monoid.First a) +deriving via (Maybe a) instance NoThunks a => NoThunks (Monoid.Last a) +deriving via (f a) instance NoThunks (f a) => NoThunks (Monoid.Alt f a) +deriving via (f a) instance NoThunks (f a) => NoThunks (Monoid.Ap f a) + +{------------------------------------------------------------------------------- + Solo +-------------------------------------------------------------------------------} + +#if MIN_VERSION_base(4,18,0) +-- GHC-9.6 and newer +instance NoThunks a => NoThunks (Solo a) where + wNoThunks ctx (MkSolo a) = wNoThunks ("Solo" : ctx) a +#elif MIN_VERSION_base(4,16,0) +-- GHC-9.2 +instance NoThunks a => NoThunks (Solo a) where + wNoThunks ctx (Solo a) = wNoThunks ("Solo" : ctx) a +#endif {------------------------------------------------------------------------------- Mutable Vars diff --git a/test/Test/NoThunks/Class.hs b/test/Test/NoThunks/Class.hs --- a/test/Test/NoThunks/Class.hs +++ b/test/Test/NoThunks/Class.hs @@ -66,12 +66,14 @@ 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 @@ , 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) @@ -104,7 +107,7 @@ -- | 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 @@ -232,6 +235,35 @@ 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 -------------------------------------------------------------------------------} @@ -523,8 +555,8 @@ {-# 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 #-} @@ -547,6 +579,13 @@ where 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