nothunks 0.1.5 → 0.2.0
raw patch · 5 files changed
+156/−38 lines, 5 files
Files
- CHANGELOG.md +8/−1
- NOTICE +1/−1
- nothunks.cabal +4/−4
- src/NoThunks/Class.hs +101/−29
- test/Test/NoThunks/Class.hs +42/−3
CHANGELOG.md view
@@ -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
NOTICE view
@@ -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.
nothunks.cabal view
@@ -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 <coot@coot.me>-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
src/NoThunks/Class.hs view
@@ -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
test/Test/NoThunks/Class.hs view
@@ -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