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.
haskell-effectful · Nov 24, 2024 · 1126e23 · 1126e23
1 parent 0ba3e9f
commit 1126e23
Show file tree

Hide file tree

Showing 6 changed files with 119 additions and 79 deletions.
diff --git 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
@@ -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 <interactive>:...
---   handler, called at src/Effectful/Dispatch/Dynamic.hs...
+--   handler, called at src/Effectful/Dispatch/Dynamic.hs:...
 --   passthrough, called at <interactive>:...
 --   handler, called at src/Effectful/Dispatch/Dynamic.hs:...
 --   send, called at <interactive>:...
@@ -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
@@ -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
@@ -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