@@ -1,62 +1,50 @@
1−{-# LANGUAGE MagicHash #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
22{-# OPTIONS_HADDOCK not-home #-}
33-- | The environment for the 'Effectful.Internal.Monad.Eff' monad.
44--
55-- This module is intended for internal use only, and may change without warning
66-- in subsequent releases.
77module Effectful.Internal.Env
8− ( -- * The environment
9− Env(..)
10− , Forks(..)
11− , EnvRef(..)
12−
13− -- ** ForkId
14− , ForkId(..)
15− , ForkIdGen(..)
16− , newForkIdGen
17− , cloneForkIdGen
18− , newForkId
19−
20− -- ** Relinker
8+ ( Env
219 , Relinker(..)
2210 , noRelinker
2311
24− -- * Operations
12+ -- * Safe operations
2513 , emptyEnv
2614 , cloneEnv
2715 , forkEnv
2816 , sizeEnv
17+ , getEnv
2918 , checkSizeEnv
3019
31− -- ** Extending and shrinking
20+ -- * Extending and shrinking
3221 , unsafeConsEnv
3322 , unsafeTailEnv
3423
35− -- ** Data retrieval and update
36− , getEnv
37− , putEnv
38− , stateEnv
39− , modifyEnv
24+ -- * Data retrieval and update
25+ , unsafePutEnv
26+ , unsafeModifyEnv
27+ , unsafeStateEnv
4028 ) where
4129
4230import Control.Monad
4331import Control.Monad.Primitive
4432import Data.IORef
4533import Data.Primitive.SmallArray
46−import GHC.Exts (Any, SmallMutableArray#)
47−import GHC.Stack (HasCallStack)
34+import Data.Word
35+import GHC.Exts (Any)
4836import Unsafe.Coerce
49−import qualified Data.IntMap.Strict as IM
37+import qualified Data.Map.Strict as M
5038
5139import Effectful.Internal.Effect
5240
5341type role Env nominal
5442
55−-- | A strict (WHNF), thread local, mutable, extensible record indexed by types
56−-- of kind 'Effect'.
43+-- | A thread local, mutable, strict (elements are kept in weak head normal
44+-- form), extensible record indexed by data types of kind 'Effect'.
5745--
5846-- Supports forking, i.e. introduction of local branches for encapsulation of
59−-- data specific to effect handlers.
47+-- data specific to effect interpreters.
6048--
6149-- Offers very good performance characteristics:
6250--
@@ -68,88 +56,39 @@ type role Env nominal
6856--
6957-- - Modification of a specific element: /O(1)/.
7058--
71−-- Here's an example of how the environment might look:
72−--
73−-- @
74−-- e00 - e01 - e05 - e07 (*)
75−-- | | |
76−-- | e06 e08 - e09
77−-- |
78−-- e02 - e03
79−-- |
80−-- e04
81−-- @
82−--
83−-- The point of execution is currently at (*), i.e. the mainline. Moreover,
84−-- currently (brackets represent forks):
85−--
86−-- - Mainline sees @[e00, e01, e05, e07]@.
87−--
88−-- - @e01@ is an interpreted effect, its handler sees @[e00][e02, e03]@.
89−--
90−-- - @e03@ is an interpreted effect, its handler sees @[e00][e02][e04]@.
91−--
92−-- - @e05@ is an interpreted effect, its handler sees @[e00, e01][e06]@.
93−--
94−-- - @e07@ is an interpreted effect, its handler sees @[e00, e01, e05][e08,
95−-- e09]@.
96−--
97−-- If an operation from @e01@ is invoked, the environment in the middle of
98−-- handling it might look like this:
99−--
100−-- @
101−-- e00 - e01 - e05 - e07
102−-- | | |
103−-- | e06 e08 - e09
104−-- |
105−-- e02 - e03 - e10 (*)
106−-- | |
107−-- e04 e11
108−-- |
109−-- e12
110−-- @
111−--
112−-- The point of execution is at (*), i.e. inside the handler of @e01@. The
113−-- handler needed to introduce @e10@ (which introduced @e11@, which in turn
114−-- introduced @e12@), so its local environment was temporarily extended with
115−-- it. Moreover, currently:
116−--
117−-- - Handler of @e01@ sees @[e00][e02, e03, e10]@.
118−--
119−-- - Handler of @e10@ sees @[e00][e02, e03][e11]@.
120−--
121−-- - Handler of @e11@ sees @[e00][e02, e03][e12]@.
122−--
12359data Env (es :: [Effect]) = Env
124− { _forks :: !Forks
125− , _globalRef :: !(IORef EnvRef)
126− , _forkIdGen :: !ForkIdGen
60+ { _forks :: Forks
61+ , _globalRef :: IORef EnvRef
62+ , _forkIdGen :: ForkIdGen
12763 }
12864
12965-- | Local forks of the environment.
130−data Forks = Forks !ForkId !Int !(IORef EnvRef) Forks | NoFork
66+data Forks = Forks ForkId Int (IORef EnvRef) Forks | NoFork
13167
132−-- | Data held in the environment.
13368data EnvRef = EnvRef
134− { _size :: !Int
135− , _data :: !(SmallMutableArray RealWorld Any)
136− , _relinkers :: !(SmallMutableArray RealWorld Any)
69+ { _capacity :: Int
70+ , _data :: SmallMutableArray RealWorld Any
71+ , _relinkers :: SmallMutableArray RealWorld Any
13772 }
13873
13974----------------------------------------
14075-- ForkId
14176
142−-- | Internal id of the fork.
143−newtype ForkId = ForkId { unForkId :: Int }
77+newtype ForkId = ForkId Word64
78+ deriving (Eq, Ord, Show)
79+
80+-- | Implicit 'ForkId' of the 'EnvRef' directly available from 'Env'.
81+globalFid :: ForkId
82+globalFid = ForkId 0
14483
14584-- | 'ForkId' generation.
14685newtype ForkIdGen = ForkIdGen (IORef ForkId)
14786
148−-- | Create a new thread local 'ForkId' generator.
87+-- | Create a new thread local unique generator.
14988newForkIdGen :: IO ForkIdGen
150−newForkIdGen = ForkIdGen <$> newIORef (ForkId 0)
89+newForkIdGen = ForkIdGen <$> newIORef (ForkId 1)
15190
152−-- | Clone the 'ForkId' generator for use in a different thread.
91+-- | Clone the unique generator for use in a different thread.
15392cloneForkIdGen :: ForkIdGen -> IO ForkIdGen
15493cloneForkIdGen (ForkIdGen ref) = fmap ForkIdGen . newIORef =<< readIORef ref
15594
@@ -163,15 +102,12 @@ newForkId (ForkIdGen ref) = do
163102----------------------------------------
164103-- Relinker
165104
166−-- | A function for relinking 'Env' objects stored in the handlers when cloning
167−-- the environment.
168−newtype Relinker :: (Effect -> Type) -> Effect -> Type where
105+newtype Relinker i (e :: Effect) where
169106 Relinker
170− :: ((forall es. Env es -> IO (Env es)) -> adapter e -> IO (adapter e))
171− -> Relinker adapter e
107+ :: ((forall es. Env es -> IO (Env es)) -> i e -> IO (i e))
108+ -> Relinker i e
172109
173−-- | A dummy 'Relinker' that does nothing.
174−noRelinker :: Relinker adapter e
110+noRelinker :: Relinker i e
175111noRelinker = Relinker $ \_ -> pure
176112
177113----------------------------------------
@@ -184,27 +120,23 @@ emptyEnv = Env NoFork <$> emptyEnvRef <*> newForkIdGen
184120-- | Clone the environment.
185121cloneEnv :: Env es -> IO (Env es)
186122cloneEnv (Env NoFork gref0 gen0) = do
187− EnvRef n es0 fs0 <- readIORef gref0
188− es <- cloneSmallMutableArray es0 0 (sizeofSmallMutableArray es0)
189− fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)
190123 gen <- cloneForkIdGen gen0
191− gref <- newIORef $ EnvRef n es fs
192− store <- newIORef IM.empty
193− relinkData gref gen store es fs n
124+ cache <- newIORef M.empty
125+ gref <- cloneEnvRef gen cache globalFid gref0
194126 pure $ Env NoFork gref gen
195127cloneEnv (Env forks@(Forks _ baseIx lref0 _) gref0 gen0) = do
196128 EnvRef _ es0 fs0 <- readIORef gref0
197129 EnvRef n _ _ <- readIORef lref0
198130 let len = baseIx + n
199− es <- newSmallArray len undefinedData
200− fs <- newSmallArray len undefinedData
131+ es <- newSmallArray len (error "undefined field")
132+ fs <- newSmallArray len (error "undefined field")
201133 baseN <- copyForks es fs len forks
202134 copySmallMutableArray es 0 es0 0 baseN
203135 copySmallMutableArray fs 0 fs0 0 baseN
204136 gen <- cloneForkIdGen gen0
205137 gref <- newIORef $ EnvRef len es fs
206− store <- newIORef IM.empty
207− relinkData gref gen store es fs n
138+ cache <- newIORef $ M.singleton globalFid gref
139+ relinkData gen cache es fs n
208140 -- The forked environment is flattened and becomes the global one.
209141 pure $ Env NoFork gref gen
210142{-# NOINLINE cloneEnv #-}
@@ -254,18 +186,33 @@ copyForks es fs len = \case
254186 copySmallMutableArray fs baseIx fs0 0 n
255187 copyForks es fs baseIx forks
256188
257−type EnvRefStore = IORef (IM.IntMap (IORef EnvRef))
189+type EnvRefCache = IORef (M.Map ForkId (IORef EnvRef))
258190
259−-- | Relink local environments hiding in the handlers.
191+-- | Clone the 'EnvRef' and put it in a cache.
192+cloneEnvRef
193+ :: ForkIdGen
194+ -> EnvRefCache
195+ -> ForkId
196+ -> IORef EnvRef
197+ -> IO (IORef EnvRef)
198+cloneEnvRef gen cache fid ref0 = do
199+ EnvRef n es0 fs0 <- readIORef ref0
200+ es <- cloneSmallMutableArray es0 0 (sizeofSmallMutableArray es0)
201+ fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)
202+ ref <- newIORef $ EnvRef n es fs
203+ modifyIORef' cache $ M.insert fid ref
204+ relinkData gen cache es fs n
205+ pure ref
206+
207+-- | Relink local environments hiding in the interpreters.
260208relinkData
261− :: IORef EnvRef
262− -> ForkIdGen
263− -> EnvRefStore
209+ :: ForkIdGen
210+ -> EnvRefCache
264211 -> SmallMutableArray RealWorld Any
265212 -> SmallMutableArray RealWorld Any
266213 -> Int
267214 -> IO ()
268−relinkData gref gen store es fs = \case
215+relinkData gen cache es fs = \case
269216 0 -> pure ()
270217 n -> do
271218 let i = n - 1
@@ -273,46 +220,29 @@ relinkData gref gen store es fs = \case
273220 readSmallArray es i
274221 >>= f relinkEnv . fromAny
275222 >>= writeSmallArray es i . toAny
276− relinkData gref gen store es fs i
223+ relinkData gen cache es fs i
277224 where
278225 relinkEnv :: Env es -> IO (Env es)
279− relinkEnv (Env forks _ _) = Env <$> relinkForks gref gen store forks
280− <*> pure gref
281− <*> pure gen
226+ relinkEnv (Env forks _ _) = do
227+ Just gref <- M.lookup globalFid <$> readIORef cache
228+ Env <$> relinkForks gen cache forks <*> pure gref <*> pure gen
282229
283−relinkForks :: IORef EnvRef -> ForkIdGen -> EnvRefStore -> Forks -> IO Forks
284−relinkForks gref gen store = \case
230+relinkForks :: ForkIdGen -> EnvRefCache -> Forks -> IO Forks
231+relinkForks gen cache = \case
285232 NoFork -> pure NoFork
286233 Forks fid baseIx lref0 forks -> do
287234 -- A specific IORef EnvRef can be held by more than one local environment
288235 -- and we need to replace all its occurences with the same, new value
289236 -- containing its clone.
290− readIORef store >>= pure . IM.lookup (unForkId fid) >>= \case
237+ readIORef cache >>= pure . M.lookup fid >>= \case
291238 Just lref -> Forks fid baseIx <$> pure lref
292− <*> relinkForks gref gen store forks
293− Nothing -> Forks fid baseIx <$> cloneEnvRef gref gen store fid lref0
294− <*> relinkForks gref gen store forks
295−
296−-- | Clone the local 'EnvRef' and put it in a store.
297−cloneEnvRef
298− :: IORef EnvRef
299− -> ForkIdGen
300− -> EnvRefStore
301− -> ForkId
302− -> IORef EnvRef
303− -> IO (IORef EnvRef)
304−cloneEnvRef gref gen store fid lref0 = do
305− EnvRef n es0 fs0 <- readIORef lref0
306− es <- cloneSmallMutableArray es0 0 (sizeofSmallMutableArray es0)
307− fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)
308− ref <- newIORef $ EnvRef n es fs
309− modifyIORef' store $ IM.insert (unForkId fid) ref
310− relinkData gref gen store es fs n
311− pure ref
239+ <*> relinkForks gen cache forks
240+ Nothing -> Forks fid baseIx <$> cloneEnvRef gen cache fid lref0
241+ <*> relinkForks gen cache forks
312242
313243----------------------------------------
314244
315−-- | Create a local fork of the environment for handlers.
245+-- | Create a local fork of the environment for interpreters.
316246forkEnv :: Env es -> IO (Env es)
317247forkEnv env@(Env NoFork gref gen) = do
318248 size <- sizeEnv env
@@ -322,7 +252,7 @@ forkEnv env@(Env NoFork gref gen) = do
322252forkEnv (Env forks@(Forks _ baseIx lref0 olderForks) gref gen) = do
323253 fid <- newForkId gen
324254 lref <- emptyEnvRef
325− (_size <$> readIORef lref0) >>= \case
255+ (_capacity <$> readIORef lref0) >>= \case
326256 -- If the fork is empty, replace it as no data is lost.
327257 0 -> pure $ Env (Forks fid baseIx lref olderForks) gref gen
328258 _ -> pure $ Env (Forks fid baseIx lref forks) gref gen
@@ -338,6 +268,12 @@ sizeEnv (Env (Forks _ baseIx lref _) _ _) = do
338268 pure $ baseIx + n
339269{-# NOINLINE sizeEnv #-}
340270
271+-- | Extract a specific data type from the environment.
272+getEnv :: forall e es i. e :> es => Env es -> IO (i e)
273+getEnv env = do
274+ (i, es) <- getLocation @e env
275+ fromAny <$> readSmallArray es i
276+
341277-- | Check that the size of the environment is the same as the expected value.
342278checkSizeEnv :: Int -> Env es -> IO ()
343279checkSizeEnv k (Env NoFork ref _) = do
@@ -355,11 +291,7 @@ checkSizeEnv k (Env (Forks _ baseIx lref _) _ _) = do
355291-- Extending and shrinking
356292
357293-- | Extend the environment with a new data type (in place).
358−--
359−-- This function is __highly unsafe__ because it renders the input 'Env'
360−-- unusable until the corresponding 'unsafeTailEnv' call is made, but it's not
361−-- checked anywhere.
362−unsafeConsEnv :: adapter e -> Relinker adapter e -> Env es -> IO (Env (e : es))
294+unsafeConsEnv :: i e -> Relinker i e -> Env es -> IO (Env (e : es))
363295unsafeConsEnv e f (Env fork gref gen) = case fork of
364296 NoFork -> do
365297 extendEnvRef gref
@@ -380,10 +312,10 @@ unsafeConsEnv e f (Env fork gref gen) = case fork of
380312 writeIORef ref $! EnvRef (n + 1) es0 fs0
381313 EQ -> do
382314 let len = doubleCapacity len0
383− es <- newSmallArray len undefinedData
315+ es <- newSmallArray len (error "undefined field")
384316 copySmallMutableArray es 0 es0 0 len0
385317 e `seq` writeSmallArray es n (toAny e)
386− fs <- newSmallArray len undefinedData
318+ fs <- newSmallArray len (error "undefined field")
387319 copySmallMutableArray fs 0 fs0 0 len0
388320 f `seq` writeSmallArray fs n (toAny f)
389321 writeIORef ref $! EnvRef (n + 1) es fs
@@ -394,13 +326,14 @@ unsafeConsEnv e f (Env fork gref gen) = case fork of
394326
395327-- | Shrink the environment by one data type (in place). Makes sure the size of
396328-- the environment is as expected.
397−--
398−-- This function is __highly unsafe__ because it renders the input 'Env'
399−-- unusable, but it's not checked anywhere.
400−unsafeTailEnv :: Int -> Env (e : es) -> IO ()
401−unsafeTailEnv len (Env fork gref _) = case fork of
402− NoFork -> shrinkEnvRef len gref
403− Forks _ baseIx lref _ -> shrinkEnvRef (len - baseIx) lref
329+unsafeTailEnv :: Int -> Env (e : es) -> IO (Env es)
330+unsafeTailEnv len (Env fork gref gen) = case fork of
331+ NoFork -> do
332+ shrinkEnvRef len gref
333+ pure $ Env NoFork gref gen
334+ Forks _ baseIx lref _ -> do
335+ shrinkEnvRef (len - baseIx) lref
336+ pure $ Env fork gref gen
404337 where
405338 shrinkEnvRef :: Int -> IORef EnvRef -> IO ()
406339 shrinkEnvRef k ref = do
@@ -408,109 +341,82 @@ unsafeTailEnv len (Env fork gref _) = case fork of
408341 if k /= n - 1
409342 then error $ "k (" ++ show k ++ ") /= n - 1 (" ++ show (n - 1) ++ ")"
410343 else do
411− writeSmallArray es k undefinedData
412− writeSmallArray fs k undefinedData
344+ writeSmallArray es k (error "undefined field")
345+ writeSmallArray fs k (error "undefined field")
413346 writeIORef ref $! EnvRef k es fs
414347{-# NOINLINE unsafeTailEnv #-}
415348
416349----------------------------------------
417350-- Data retrieval and update
418351
419−-- | Extract a specific data type from the environment.
420−getEnv
421− :: forall e adapter es. e :> es
422− => Env es
423− -> IO (adapter e)
424−getEnv env = do
425− Location i es <- getLocation (reifyIndex @e @es) env
426− fromAny <$> readSmallArray es i
427−
428352-- | Replace the data type in the environment with a new value (in place).
429−putEnv
430− :: forall e adapter es. e :> es
431− => Env es
432− -> adapter e
433− -> IO ()
434−putEnv env e = do
435− Location i es <- getLocation (reifyIndex @e @es) env
353+unsafePutEnv :: forall e es i. e :> es => i e -> Env es -> IO ()
354+unsafePutEnv e env = do
355+ (i, es) <- getLocation @e env
356+ e `seq` writeSmallArray es i (toAny e)
357+
358+-- | Modify the data type in the environment (in place).
359+unsafeModifyEnv :: forall e es i. e :> es => (i e -> i e) -> Env es -> IO ()
360+unsafeModifyEnv f env = do
361+ (i, es) <- getLocation @e env
362+ e <- f . fromAny <$> readSmallArray es i
436363 e `seq` writeSmallArray es i (toAny e)
437364
438365-- | Modify the data type in the environment (in place) and return a value.
439−stateEnv
440− :: forall e adapter es a. e :> es
441− => Env es
442− -> (adapter e -> (a, adapter e))
443− -> IO a
444−stateEnv env f = do
445− Location i es <- getLocation (reifyIndex @e @es) env
366+unsafeStateEnv :: forall e es i a. e :> es => (i e -> (a, i e)) -> Env es -> IO a
367+unsafeStateEnv f env = do
368+ (i, es) <- getLocation @e env
446369 (a, e) <- f . fromAny <$> readSmallArray es i
447370 e `seq` writeSmallArray es i (toAny e)
448371 pure a
449372
450−-- | Modify the data type in the environment (in place).
451−modifyEnv
452− :: forall e adapter es. e :> es
453− => Env es
454− -> (adapter e -> adapter e)
455− -> IO ()
456−modifyEnv env f = do
457− Location i es <- getLocation (reifyIndex @e @es) env
458− e <- f . fromAny <$> readSmallArray es i
459− e `seq` writeSmallArray es i (toAny e)
460−
461373----------------------------------------
462374-- Internal helpers
463375
464−undefinedData :: HasCallStack => a
465−undefinedData = error "undefined data"
466−
467376emptyEnvRef :: IO (IORef EnvRef)
468377emptyEnvRef = do
469− es <- newSmallArray 0 undefinedData
470− fs <- newSmallArray 0 undefinedData
378+ es <- newSmallArray 0 (error "undefined field")
379+ fs <- newSmallArray 0 (error "undefined field")
471380 newIORef $ EnvRef 0 es fs
472381
473−-- | Location with unboxed fields to make GHC generate Core without unnecessary
474−-- reboxing around the local 'go' function from 'getLocation'.
475−data Location = Location !Int !(SmallMutableArray RealWorld Any)
476−
477382-- | Determine location of the data type in the environment.
478383getLocation
479− :: Int
480− -> Env es
481− -> IO Location
482−getLocation ixE (Env fork ref _) = do
483− EnvRef n es@(SmallMutableArray es#) _ <- readIORef ref
384+ :: forall e es. e :> es
385+ => Env es
386+ -> IO (Int, SmallMutableArray RealWorld Any)
387+getLocation (Env fork ref _) = do
388+ EnvRef n es _ <- readIORef ref
484389 -- Optimized for the common access pattern:
485390 --
486391 -- - Most application code has no access to forks, in which case we look at
487392 -- the global EnvRef.
488393 --
489− -- - Effect handlers will most likely access the newest fork with handler
490− -- specific effects for reinterpretation.
394+ -- - Interpreters will most likely access the newest fork for reinterpretation
395+ -- of effects that are there.
491396 case fork of
492− NoFork -> pure $ Location (ix n) es
397+ NoFork -> pure (ix n, es)
493398 Forks _ baseIx lref forks -> do
494399 EnvRef ln les _ <- readIORef lref
495400 let i = ix (baseIx + ln)
496401 if i >= baseIx
497− then pure $ Location (i - baseIx) les
498− else go es# i forks
402+ then pure (i - baseIx, les)
403+ else go es i forks
499404 where
500− go :: SmallMutableArray# RealWorld Any
405+ go :: SmallMutableArray RealWorld Any
501406 -> Int
502407 -> Forks
503− -> IO Location
504− go es# i = \case
505− NoFork -> pure $ Location i (SmallMutableArray es#)
408+ -> IO (Int, SmallMutableArray RealWorld Any)
409+ go es i = \case
410+ NoFork -> pure (i, es)
506411 Forks _ baseIx lref forks -> do
507412 EnvRef _ les _ <- readIORef lref
508413 if i >= baseIx
509− then pure $ Location (i - baseIx) les
510− else go es# i forks
414+ then pure (i - baseIx, les)
415+ else go es i forks
511416
512417 ix :: Int -> Int
513− ix n = n - ixE - 1
418+ ix n = n - reifyIndex @e @es - 1
419+{-# INLINE getLocation #-}
514420
515421toAny :: a -> Any
516422toAny = unsafeCoerce