From 1126e230dfb3bb39c79c19a49e63079a2b39d533 Mon Sep 17 00:00:00 2001 From: Andrzej Rybczak Date: Sun, 24 Nov 2024 15:33:37 +0100 Subject: [PATCH] Fix a potential space leak related to HasCallStack quirks (#279) The following program: ```haskell import Control.Monad import Effectful import Effectful.Concurrent import Effectful.Concurrent.MVar import Effectful.Reader.Dynamic import Effectful.Provider import Effectful.Provider.List f :: Concurrent :> es => MVar () -> Int -> Eff es () f var = \case 0 -> putMVar var () n -> void $ forkIO $ f var (n - 1) main :: IO () main = runEff . runReader () . runProvider_ (\() -> runReader ()) . runProviderList_ @'[Reader ()] (\() -> runReader ()) . runConcurrent $ do var <- newEmptyMVar f var 10000000 takeMVar var ``` used to leak memory because GHC attaches a new stack frame to fields with HasCallStack constraints on every record reconstruction. Here it means every relinking, so if the relinks are nested, call stacks atached to these fields will keep growing. The workaround is to wrap these fields in newtypes, see https://gitlab.haskell.org/ghc/ghc/-/issues/25520 for more information. --- effectful-core/CHANGELOG.md | 3 + .../src/Effectful/Dispatch/Dynamic.hs | 100 +++++++++--------- .../src/Effectful/Internal/Monad.hs | 17 +-- effectful-core/src/Effectful/Provider.hs | 37 +++++-- effectful-core/src/Effectful/Provider/List.hs | 38 ++++--- effectful/CHANGELOG.md | 3 + 6 files changed, 119 insertions(+), 79 deletions(-) diff --git a/effectful-core/CHANGELOG.md b/effectful-core/CHANGELOG.md index ac07181..938bfe2 100644 --- a/effectful-core/CHANGELOG.md +++ b/effectful-core/CHANGELOG.md @@ -2,6 +2,9 @@ * Add `passthrough` to `Effectful.Dispatch.Dynamic` for passing operations to the upstream handler within `interpose` and `impose` without having to fully pattern match on them. +* **Bugfixes**: + - Fix a potential space leak related to `HasCallStack` quirks + (https://gitlab.haskell.org/ghc/ghc/-/issues/25520). # effectful-core-2.5.0.0 (2024-10-23) * Add `plusEff` (specialized version of `<|>`) to `Effectful.NonDet` and make diff --git a/effectful-core/src/Effectful/Dispatch/Dynamic.hs b/effectful-core/src/Effectful/Dispatch/Dynamic.hs index 3bf1a32..aacbde3 100644 --- a/effectful-core/src/Effectful/Dispatch/Dynamic.hs +++ b/effectful-core/src/Effectful/Dispatch/Dynamic.hs @@ -425,13 +425,13 @@ passthrough -- ^ The operation. -> Eff es a passthrough (LocalEnv les) op = unsafeEff $ \es -> do - Handler handlerEs handler <- getEnv es + Handler handlerEs (HandlerImpl handler) <- getEnv es when (envStorage les /= envStorage handlerEs) $ do error "les and handlerEs point to different Storages" - -- Prevent internal functions that rebind the effect handler from polluting - -- its call stack by freezing it. Note that functions 'interpret', - -- 'reinterpret', 'interpose' and 'impose' need to thaw it so that useful - -- stack frames from inside the effect handler continue to be added. + -- Prevent the addition of unnecessary 'handler' stack frame to the call + -- stack. Note that functions 'interpret', 'reinterpret', 'interpose' and + -- 'impose' need to thaw the call stack so that useful stack frames from + -- inside the effect handler continue to be added. unEff (withFrozenCallStack handler (LocalEnv les) op) handlerEs {-# NOINLINE passthrough #-} @@ -448,8 +448,8 @@ interpret -- ^ The effect handler. -> Eff (e : es) a -> Eff es a -interpret handler action = interpretImpl action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in handler) +interpret handler action = interpretImpl action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) -- | 'interpret' with the effect handler as the last argument. -- @@ -460,8 +460,8 @@ interpretWith -> EffectHandler e es -- ^ The effect handler. -> Eff es a -interpretWith action handler = interpretImpl action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in handler) +interpretWith action handler = interpretImpl action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) -- | Interpret an effect using other, private effects. -- @@ -474,8 +474,8 @@ reinterpret -- ^ The effect handler. -> Eff (e : es) a -> Eff es b -reinterpret runSetup handler action = reinterpretImpl runSetup action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in handler) +reinterpret runSetup handler action = reinterpretImpl runSetup action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) -- | 'reinterpret' with the effect handler as the last argument. -- @@ -488,8 +488,8 @@ reinterpretWith -> EffectHandler e handlerEs -- ^ The effect handler. -> Eff es b -reinterpretWith runSetup action handler = reinterpretImpl runSetup action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in handler) +reinterpretWith runSetup action handler = reinterpretImpl runSetup action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) -- | Replace the handler of an existing effect with a new one. -- @@ -541,7 +541,7 @@ reinterpretWith runSetup action handler = reinterpretImpl runSetup action $ \es -- *** Exception: Op3 not implemented -- CallStack (from HasCallStack): -- error, called at :... --- handler, called at src/Effectful/Dispatch/Dynamic.hs... +-- handler, called at src/Effectful/Dispatch/Dynamic.hs:... -- passthrough, called at :... -- handler, called at src/Effectful/Dispatch/Dynamic.hs:... -- send, called at :... @@ -551,8 +551,8 @@ interpose -- ^ The effect handler. -> Eff es a -> Eff es a -interpose handler action = interposeImpl action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in handler) +interpose handler action = interposeImpl action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) -- | 'interpose' with the effect handler as the last argument. -- @@ -563,8 +563,8 @@ interposeWith -> EffectHandler e es -- ^ The effect handler. -> Eff es a -interposeWith action handler = interposeImpl action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in handler) +interposeWith action handler = interposeImpl action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) -- | Replace the handler of an existing effect with a new one that uses other, -- private effects. @@ -578,8 +578,8 @@ impose -- ^ The effect handler. -> Eff es a -> Eff es b -impose runSetup handler action = imposeImpl runSetup action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in handler) +impose runSetup handler action = imposeImpl runSetup action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) -- | 'impose' with the effect handler as the last argument. -- @@ -592,8 +592,8 @@ imposeWith -> EffectHandler e handlerEs -- ^ The effect handler. -> Eff es b -imposeWith runSetup action handler = imposeImpl runSetup action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in handler) +imposeWith runSetup action handler = imposeImpl runSetup action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) ---------------------------------------- -- First order effects @@ -616,8 +616,8 @@ interpret_ -- ^ The effect handler. -> Eff (e : es) a -> Eff es a -interpret_ handler action = interpretImpl action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in const handler) +interpret_ handler action = interpretImpl action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler) -- | 'interpretWith' for first order effects. -- @@ -628,8 +628,8 @@ interpretWith_ -> EffectHandler_ e es -- ^ The effect handler. -> Eff es a -interpretWith_ action handler = interpretImpl action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in const handler) +interpretWith_ action handler = interpretImpl action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler) -- | 'reinterpret' for first order effects. -- @@ -642,8 +642,8 @@ reinterpret_ -- ^ The effect handler. -> Eff (e : es) a -> Eff es b -reinterpret_ runSetup handler action = reinterpretImpl runSetup action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in const handler) +reinterpret_ runSetup handler action = reinterpretImpl runSetup action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler) -- | 'reinterpretWith' for first order effects. -- @@ -656,8 +656,8 @@ reinterpretWith_ -> EffectHandler_ e handlerEs -- ^ The effect handler. -> Eff es b -reinterpretWith_ runSetup action handler = reinterpretImpl runSetup action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in const handler) +reinterpretWith_ runSetup action handler = reinterpretImpl runSetup action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler) -- | 'interpose' for first order effects. -- @@ -668,8 +668,8 @@ interpose_ -- ^ The effect handler. -> Eff es a -> Eff es a -interpose_ handler action = interposeImpl action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in const handler) +interpose_ handler action = interposeImpl action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler) -- | 'interposeWith' for first order effects. -- @@ -680,8 +680,8 @@ interposeWith_ -> EffectHandler_ e es -- ^ The effect handler. -> Eff es a -interposeWith_ action handler = interposeImpl action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in const handler) +interposeWith_ action handler = interposeImpl action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler) -- | 'impose' for first order effects. -- @@ -694,8 +694,8 @@ impose_ -- ^ The effect handler. -> Eff es a -> Eff es b -impose_ runSetup handler action = imposeImpl runSetup action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in const handler) +impose_ runSetup handler action = imposeImpl runSetup action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler) -- | 'imposeWith' for first order effects. -- @@ -708,8 +708,8 @@ imposeWith_ -> EffectHandler_ e handlerEs -- ^ The effect handler. -> Eff es b -imposeWith_ runSetup action handler = imposeImpl runSetup action $ \es -> - Handler es (let ?callStack = thawCallStack ?callStack in const handler) +imposeWith_ runSetup action handler = imposeImpl runSetup action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler) ---------------------------------------- -- Unlifts @@ -1140,29 +1140,29 @@ instance interpretImpl :: (HasCallStack, DispatchOf e ~ Dynamic) => Eff (e : es) a - -> (Env es -> Handler e) + -> HandlerImpl e es -> Eff es a -interpretImpl action mkHandler = unsafeEff $ \es -> do - (`unEff` es) $ runHandler (mkHandler es) action +interpretImpl action handlerImpl = unsafeEff $ \es -> do + (`unEff` es) $ runHandler (Handler es handlerImpl) action {-# INLINE interpretImpl #-} reinterpretImpl :: (HasCallStack, DispatchOf e ~ Dynamic) => (Eff handlerEs a -> Eff es b) -> Eff (e : es) a - -> (Env handlerEs -> Handler e) + -> HandlerImpl e handlerEs -> Eff es b -reinterpretImpl runSetup action mkHandler = unsafeEff $ \es -> do +reinterpretImpl runSetup action handlerImpl = unsafeEff $ \es -> do (`unEff` es) . runSetup . unsafeEff $ \handlerEs -> do - (`unEff` es) $ runHandler (mkHandler handlerEs) action + (`unEff` es) $ runHandler (Handler handlerEs handlerImpl) action {-# INLINE reinterpretImpl #-} interposeImpl :: forall e es a. (HasCallStack, DispatchOf e ~ Dynamic, e :> es) => Eff es a - -> (Env es -> Handler e) + -> HandlerImpl e es -> Eff es a -interposeImpl action mkHandler = unsafeEff $ \es -> do +interposeImpl action handlerImpl = unsafeEff $ \es -> do inlineBracket (do origHandler <- getEnv @e es @@ -1176,7 +1176,7 @@ interposeImpl action mkHandler = unsafeEff $ \es -> do (\newEs -> do -- Replace the original handler with a new one. Note that 'newEs' -- will still see the original handler. - putEnv es $ mkHandler newEs + putEnv es $ Handler newEs handlerImpl unEff action es ) {-# INLINE interposeImpl #-} @@ -1185,9 +1185,9 @@ imposeImpl :: forall e es handlerEs a b. (HasCallStack, DispatchOf e ~ Dynamic, e :> es) => (Eff handlerEs a -> Eff es b) -> Eff es a - -> (Env handlerEs -> Handler e) + -> HandlerImpl e handlerEs -> Eff es b -imposeImpl runSetup action mkHandler = unsafeEff $ \es -> do +imposeImpl runSetup action handlerImpl = unsafeEff $ \es -> do inlineBracket (do origHandler <- getEnv @e es @@ -1203,7 +1203,7 @@ imposeImpl runSetup action mkHandler = unsafeEff $ \es -> do -- Replace the original handler with a new one. Note that -- 'newEs' (and thus 'handlerEs') wil still see the original -- handler. - putEnv es $ mkHandler handlerEs + putEnv es $ Handler handlerEs handlerImpl unEff action es ) {-# INLINE imposeImpl #-} diff --git a/effectful-core/src/Effectful/Internal/Monad.hs b/effectful-core/src/Effectful/Internal/Monad.hs index 2059262..414ee05 100644 --- a/effectful-core/src/Effectful/Internal/Monad.hs +++ b/effectful-core/src/Effectful/Internal/Monad.hs @@ -59,6 +59,7 @@ module Effectful.Internal.Monad , EffectHandler , LocalEnv(..) , Handler(..) + , HandlerImpl(..) , relinkHandler , runHandler , send @@ -522,10 +523,14 @@ type EffectHandler (e :: Effect) (es :: [Effect]) -- ^ The operation. -> Eff es a +-- | Wrapper to prevent a space leak on reconstruction of 'Handler' in +-- 'relinkHandler' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520). +newtype HandlerImpl e es = HandlerImpl (EffectHandler e es) + -- | An internal representation of dynamically dispatched effects, i.e. the -- effect handler bundled with its environment. data Handler :: Effect -> Type where - Handler :: !(Env handlerEs) -> !(EffectHandler e handlerEs) -> Handler e + Handler :: !(Env handlerEs) -> !(HandlerImpl e handlerEs) -> Handler e type instance EffectRep Dynamic = Handler relinkHandler :: Relinker Handler e @@ -552,13 +557,13 @@ send -- ^ The operation. -> Eff es a send op = unsafeEff $ \es -> do - Handler handlerEs handler <- getEnv es + Handler handlerEs (HandlerImpl handler) <- getEnv es when (envStorage es /= envStorage handlerEs) $ do error "es and handlerEs point to different Storages" - -- Prevent internal functions that rebind the effect handler from polluting - -- its call stack by freezing it. Note that functions 'interpret', - -- 'reinterpret', 'interpose' and 'impose' need to thaw it so that useful - -- stack frames from inside the effect handler continue to be added. + -- Prevent the addition of unnecessary 'handler' stack frame to the call + -- stack. Note that functions 'interpret', 'reinterpret', 'interpose' and + -- 'impose' need to thaw the call stack so that useful stack frames from + -- inside the effect handler continue to be added. unEff (withFrozenCallStack handler (LocalEnv es) op) handlerEs {-# NOINLINE send #-} diff --git a/effectful-core/src/Effectful/Provider.hs b/effectful-core/src/Effectful/Provider.hs index f5c5145..7458603 100644 --- a/effectful-core/src/Effectful/Provider.hs +++ b/effectful-core/src/Effectful/Provider.hs @@ -123,10 +123,17 @@ type Provider_ e input = Provider e input Identity type instance DispatchOf (Provider e input f) = Static NoSideEffects +-- | Wrapper to prevent a space leak on reconstruction of 'Provider' in +-- 'relinkProvider' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520). +newtype ProviderImpl input f e es where + ProviderImpl + :: (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r)) + -> ProviderImpl input f e es + data instance StaticRep (Provider e input f) where Provider :: !(Env handlerEs) - -> !(forall r. HasCallStack => input -> Eff (e : handlerEs) r -> Eff handlerEs (f r)) + -> !(ProviderImpl input f e handlerEs) -> StaticRep (Provider e input f) -- | Run the 'Provider' effect with a given effect handler. @@ -136,14 +143,8 @@ runProvider -- ^ The effect handler. -> Eff (Provider e input f : es) a -> Eff es a -runProvider provider m = unsafeEff $ \es0 -> do - inlineBracket - (consEnv (mkProvider es0) relinkProvider es0) - unconsEnv - (\es -> unEff m es) - where - -- Corresponds to withFrozenCallStack in provideWith. - mkProvider es = Provider es (let ?callStack = thawCallStack ?callStack in provider) +runProvider provider action = runProviderImpl action $ + ProviderImpl (let ?callStack = thawCallStack ?callStack in provider) -- | Run the 'Provider' effect with a given effect handler that doesn't change -- its return type. @@ -153,7 +154,9 @@ runProvider_ -- ^ The effect handler. -> Eff (Provider_ e input : es) a -> Eff es a -runProvider_ provider = runProvider $ \input -> coerce . provider input +runProvider_ provider action = runProviderImpl action $ + ProviderImpl $ let ?callStack = thawCallStack ?callStack + in \input -> coerce . provider input -- | Run the effect handler. provide :: (HasCallStack, Provider e () f :> es) => Eff (e : es) a -> Eff es (f a) @@ -171,7 +174,7 @@ provideWith -> Eff (e : es) a -> Eff es (f a) provideWith input action = unsafeEff $ \es -> do - Provider handlerEs handler <- getEnv es + Provider handlerEs (ProviderImpl handler) <- getEnv es (`unEff` handlerEs) -- Corresponds to thawCallStack in runProvider. . withFrozenCallStack handler input @@ -194,6 +197,18 @@ provideWith_ input = adapt . provideWith input ---------------------------------------- -- Helpers +runProviderImpl + :: HasCallStack + => Eff (Provider e input f : es) a + -> ProviderImpl input f e es + -> Eff es a +runProviderImpl action providerImpl = unsafeEff $ \es -> do + inlineBracket + (consEnv (Provider es providerImpl) relinkProvider es) + unconsEnv + (unEff action) +{-# INLINE runProviderImpl #-} + relinkProvider :: Relinker StaticRep (Provider e input f) relinkProvider = Relinker $ \relink (Provider handlerEs run) -> do newHandlerEs <- relink handlerEs diff --git a/effectful-core/src/Effectful/Provider/List.hs b/effectful-core/src/Effectful/Provider/List.hs index 75b2140..4f1a76f 100644 --- a/effectful-core/src/Effectful/Provider/List.hs +++ b/effectful-core/src/Effectful/Provider/List.hs @@ -51,11 +51,18 @@ type ProviderList_ providedEs input = ProviderList providedEs input Identity type instance DispatchOf (ProviderList providedEs input f) = Static NoSideEffects +-- | Wrapper to prevent a space leak on reconstruction of 'ProviderList' in +-- 'relinkProviderList' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520). +newtype ProviderListImpl input f providedEs es where + ProviderListImpl + :: (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es (f r)) + -> ProviderListImpl input f providedEs es + data instance StaticRep (ProviderList providedEs input f) where ProviderList :: KnownEffects providedEs => !(Env handlerEs) - -> !(forall r. HasCallStack => input -> Eff (providedEs ++ handlerEs) r -> Eff handlerEs (f r)) + -> !(ProviderListImpl input f providedEs handlerEs) -> StaticRep (ProviderList providedEs input f) -- | Run the 'ProviderList' effect with a given handler. @@ -65,15 +72,8 @@ runProviderList -- ^ The handler. -> Eff (ProviderList providedEs input f : es) a -> Eff es a -runProviderList providerList m = unsafeEff $ \es0 -> do - inlineBracket - (consEnv (mkProviderList es0) relinkProviderList es0) - unconsEnv - (\es -> unEff m es) - where - -- Corresponds to withFrozenCallStack in provideListWith. - mkProviderList es = - ProviderList es (let ?callStack = thawCallStack ?callStack in providerList) +runProviderList providerList action = runProviderListImpl action $ + ProviderListImpl (let ?callStack = thawCallStack ?callStack in providerList) -- | Run the 'Provider' effect with a given handler that doesn't change its -- return type. @@ -83,7 +83,9 @@ runProviderList_ -- ^ The handler. -> Eff (ProviderList_ providedEs input : es) a -> Eff es a -runProviderList_ providerList = runProviderList $ \input -> coerce . providerList input +runProviderList_ providerList action = runProviderListImpl action $ + ProviderListImpl $ let ?callStack = thawCallStack ?callStack + in \input -> coerce . providerList input -- | Run the handler. provideList @@ -110,7 +112,7 @@ provideListWith -> Eff (providedEs ++ es) a -> Eff es (f a) provideListWith input action = unsafeEff $ \es -> do - ProviderList (handlerEs :: Env handlerEs) providerList <- do + ProviderList (handlerEs :: Env handlerEs) (ProviderListImpl providerList) <- do getEnv @(ProviderList providedEs input f) es (`unEff` handlerEs) -- Corresponds to a thawCallStack in runProviderList. @@ -134,6 +136,18 @@ provideListWith_ input = adapt . provideListWith @providedEs input ---------------------------------------- -- Helpers +runProviderListImpl + :: (HasCallStack, KnownEffects providedEs) + => Eff (ProviderList providedEs input f : es) a + -> ProviderListImpl input f providedEs es + -> Eff es a +runProviderListImpl action providerListImpl = unsafeEff $ \es -> do + inlineBracket + (consEnv (ProviderList es providerListImpl) relinkProviderList es) + unconsEnv + (unEff action) +{-# INLINE runProviderListImpl #-} + relinkProviderList :: Relinker StaticRep (ProviderList e input f) relinkProviderList = Relinker $ \relink (ProviderList handlerEs run) -> do newHandlerEs <- relink handlerEs diff --git a/effectful/CHANGELOG.md b/effectful/CHANGELOG.md index d00a065..c986d1a 100644 --- a/effectful/CHANGELOG.md +++ b/effectful/CHANGELOG.md @@ -2,6 +2,9 @@ * Add `passthrough` to `Effectful.Dispatch.Dynamic` for passing operations to the upstream handler within `interpose` and `impose` without having to fully pattern match on them. +* **Bugfixes**: + - Fix a potential space leak related to `HasCallStack` quirks + (https://gitlab.haskell.org/ghc/ghc/-/issues/25520). # effectful-2.5.0.0 (2024-10-23) * Add `plusEff` (specialized version of `<|>`) to `Effectful.NonDet` and make