diff --git a/CHANGELOG.md b/CHANGELOG.md index 0ba35e9..6829f3e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,9 @@ ## next version +* 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). * `NoThunks` instance for `Data.Tuple.Solo`. * `NoThunks` instances for `Data.Semigroup` and `Data.Monoid` newtype wrappers. diff --git a/README.md b/README.md index a1e5794..9269d01 100644 --- a/README.md +++ b/README.md @@ -12,3 +12,11 @@ See my presentation [MuniHac 2020: Being lazy without being bloated](https://www.youtube.com/watch?v=7t6wt7ByBWg) for an overview, motivating the library and explaining how it is intended to be 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 +feature in `GHC-9.2` (although an earlier version of `whereFrom` +is available in `base`). diff --git a/nothunks.cabal b/nothunks.cabal index 827898c..2077c2b 100644 --- a/nothunks.cabal +++ b/nothunks.cabal @@ -41,7 +41,7 @@ library 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 index bc1af26..264f628 100644 --- 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 #-} @@ -69,6 +70,10 @@ import GHC.Stack 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 @@ -132,12 +137,11 @@ class NoThunks a where noThunks :: Context -> a -> IO (Maybe ThunkInfo) noThunks ctxt x = do isThunk <- checkIsThunk x + c <- getThunkContext (showTypeOf (Proxy @a)) x + let ctxt' = c : ctxt if isThunk then return $ Just ThunkInfo { thunkContext = ctxt' } 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. -- @@ -213,10 +217,28 @@ newtype ThunkInfo = ThunkInfo { -- > ["Int","List","(,)"] an Int in the [Int] in the pair -- -- Note: prior to `ghc-9.6` a list was indicated by `[]`. - thunkContext :: Context + -- + -- 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 + +infoProvContext :: InfoProv -> String +infoProvContext InfoProv { ipSrcFile, ipSrcSpan, + ipLabel, ipTyDesc } = + ipLabel ++ " :: " ++ ipTyDesc + ++ " @ " ++ ipSrcFile ++ ":" ++ ipSrcSpan +#else +getThunkContext c _ = return c +#endif + + {-# NOINLINE unsafeNoThunks #-} -- | Call 'noThunks' in a pure context (relies on 'unsafePerformIO'). unsafeNoThunks :: NoThunks a => a -> Maybe ThunkInfo @@ -362,8 +384,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 return $ if containsThunks - then Just $ ThunkInfo { thunkContext = "..." : ctxt } + then Just $ ThunkInfo { thunkContext = c : ctxt } else Nothing {------------------------------------------------------------------------------- @@ -513,14 +536,14 @@ deriving via (f a) instance NoThunks (f a) => NoThunks (Monoid.Ap f a) Solo -------------------------------------------------------------------------------} -#if MIN_VERSION_base(4,16,0) +#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 -#elif MIN_VERSION_base(4,17,0) --- GHC-9.4 and newer -instance NoThunks a => NoThunks (Solo a) where - wNoThunks ctx (MkSolo a) = wNoThunks ("Solo" : ctx) a #endif {-------------------------------------------------------------------------------