@@ -1,52 +1,40 @@
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
@@ -56,7 +44,7 @@ type role Env nominal
5644-- 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--
@@ -81,17 +69,17 @@ type role Env nominal
8169-- @
8270--
8371-- The point of execution is currently at (*), i.e. the mainline. Moreover,
84−-- currently (brackets represent forks):
72+-- currently:
8573--
8674-- - Mainline sees @[e00, e01, e05, e07]@.
8775--
88−-- - @e01@ is an interpreted effect, its handler sees @[e00][e02, e03]@.
76+-- - @e01@ is an interpreted effect, its handler sees @[e00, e02, e03]@.
8977--
90−-- - @e03@ is an interpreted effect, its handler sees @[e00][e02][e04]@.
78+-- - @e03@ is an interpreted effect, its handler sees @[e00, e02, e04]@.
9179--
92−-- - @e05@ is an interpreted effect, its handler sees @[e00, e01][e06]@.
80+-- - @e05@ is an interpreted effect, its handler sees @[e00, e01, e06]@.
9381--
94−-- - @e07@ is an interpreted effect, its handler sees @[e00, e01, e05][e08,
82+-- - @e07@ is an interpreted effect, its handler sees @[e00, e01, e05, e08,
9583-- e09]@.
9684--
9785-- If an operation from @e01@ is invoked, the environment in the middle of
@@ -114,42 +102,45 @@ type role Env nominal
114102-- introduced @e12@), so its local environment was temporarily extended with
115103-- it. Moreover, currently:
116104--
117−-- - Handler of @e01@ sees @[e00][e02, e03, e10]@.
105+-- - Handler of @e01@ sees @[e00, e02, e03, e10]@.
118106--
119−-- - Handler of @e10@ sees @[e00][e02, e03][e11]@.
107+-- - Handler of @e10@ sees @[e00, e02, e03, e11]@.
120108--
121−-- - Handler of @e11@ sees @[e00][e02, e03][e12]@.
109+-- - Handler of @e11@ sees @[e00, e02, e03, e12]@.
122110--
123111data Env (es :: [Effect]) = Env
124− { _forks :: !Forks
125− , _globalRef :: !(IORef EnvRef)
126− , _forkIdGen :: !ForkIdGen
112+ { _forks :: Forks
113+ , _globalRef :: IORef EnvRef
114+ , _forkIdGen :: ForkIdGen
127115 }
128116
129117-- | Local forks of the environment.
130−data Forks = Forks !ForkId !Int !(IORef EnvRef) Forks | NoFork
118+data Forks = Forks ForkId Int (IORef EnvRef) Forks | NoFork
131119
132−-- | Data held in the environment.
133120data EnvRef = EnvRef
134− { _size :: !Int
135− , _data :: !(SmallMutableArray RealWorld Any)
136− , _relinkers :: !(SmallMutableArray RealWorld Any)
121+ { _size :: Int
122+ , _data :: SmallMutableArray RealWorld Any
123+ , _relinkers :: SmallMutableArray RealWorld Any
137124 }
138125
139126----------------------------------------
140127-- ForkId
141128
142−-- | Internal id of the fork.
143−newtype ForkId = ForkId { unForkId :: Int }
129+newtype ForkId = ForkId Word64
130+ deriving (Eq, Ord, Show)
131+
132+-- | Implicit 'ForkId' of the 'EnvRef' directly available from 'Env'.
133+globalFid :: ForkId
134+globalFid = ForkId 0
144135
145136-- | 'ForkId' generation.
146137newtype ForkIdGen = ForkIdGen (IORef ForkId)
147138
148−-- | Create a new thread local 'ForkId' generator.
139+-- | Create a new thread local unique generator.
149140newForkIdGen :: IO ForkIdGen
150−newForkIdGen = ForkIdGen <$> newIORef (ForkId 0)
141+newForkIdGen = ForkIdGen <$> newIORef (ForkId 1)
151142
152−-- | Clone the 'ForkId' generator for use in a different thread.
143+-- | Clone the unique generator for use in a different thread.
153144cloneForkIdGen :: ForkIdGen -> IO ForkIdGen
154145cloneForkIdGen (ForkIdGen ref) = fmap ForkIdGen . newIORef =<< readIORef ref
155146
@@ -163,15 +154,12 @@ newForkId (ForkIdGen ref) = do
163154----------------------------------------
164155-- Relinker
165156
166−-- | A function for relinking 'Env' objects stored in the handlers when cloning
167−-- the environment.
168−newtype Relinker :: (Effect -> Type) -> Effect -> Type where
157+newtype Relinker i (e :: Effect) where
169158 Relinker
170− :: ((forall es. Env es -> IO (Env es)) -> adapter e -> IO (adapter e))
171− -> Relinker adapter e
159+ :: ((forall es. Env es -> IO (Env es)) -> i e -> IO (i e))
160+ -> Relinker i e
172161
173−-- | A dummy 'Relinker' that does nothing.
174−noRelinker :: Relinker adapter e
162+noRelinker :: Relinker i e
175163noRelinker = Relinker $ \_ -> pure
176164
177165----------------------------------------
@@ -184,27 +172,23 @@ emptyEnv = Env NoFork <$> emptyEnvRef <*> newForkIdGen
184172-- | Clone the environment.
185173cloneEnv :: Env es -> IO (Env es)
186174cloneEnv (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)
190175 gen <- cloneForkIdGen gen0
191− gref <- newIORef $ EnvRef n es fs
192− store <- newIORef IM.empty
193− relinkData gref gen store es fs n
176+ cache <- newIORef M.empty
177+ gref <- cloneEnvRef gen cache globalFid gref0
194178 pure $ Env NoFork gref gen
195179cloneEnv (Env forks@(Forks _ baseIx lref0 _) gref0 gen0) = do
196180 EnvRef _ es0 fs0 <- readIORef gref0
197181 EnvRef n _ _ <- readIORef lref0
198182 let len = baseIx + n
199− es <- newSmallArray len undefinedData
200− fs <- newSmallArray len undefinedData
183+ es <- newSmallArray len (error "undefined field")
184+ fs <- newSmallArray len (error "undefined field")
201185 baseN <- copyForks es fs len forks
202186 copySmallMutableArray es 0 es0 0 baseN
203187 copySmallMutableArray fs 0 fs0 0 baseN
204188 gen <- cloneForkIdGen gen0
205189 gref <- newIORef $ EnvRef len es fs
206− store <- newIORef IM.empty
207− relinkData gref gen store es fs n
190+ cache <- newIORef $ M.singleton globalFid gref
191+ relinkData gen cache es fs n
208192 -- The forked environment is flattened and becomes the global one.
209193 pure $ Env NoFork gref gen
210194{-# NOINLINE cloneEnv #-}
@@ -254,18 +238,33 @@ copyForks es fs len = \case
254238 copySmallMutableArray fs baseIx fs0 0 n
255239 copyForks es fs baseIx forks
256240
257−type EnvRefStore = IORef (IM.IntMap (IORef EnvRef))
241+type EnvRefCache = IORef (M.Map ForkId (IORef EnvRef))
242+
243+-- | Clone the 'EnvRef' and put it in a cache.
244+cloneEnvRef
245+ :: ForkIdGen
246+ -> EnvRefCache
247+ -> ForkId
248+ -> IORef EnvRef
249+ -> IO (IORef EnvRef)
250+cloneEnvRef gen cache fid ref0 = do
251+ EnvRef n es0 fs0 <- readIORef ref0
252+ es <- cloneSmallMutableArray es0 0 (sizeofSmallMutableArray es0)
253+ fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)
254+ ref <- newIORef $ EnvRef n es fs
255+ modifyIORef' cache $ M.insert fid ref
256+ relinkData gen cache es fs n
257+ pure ref
258258
259−-- | Relink local environments hiding in the handlers.
259+-- | Relink local environments hiding in the interpreters.
260260relinkData
261− :: IORef EnvRef
262− -> ForkIdGen
263− -> EnvRefStore
261+ :: ForkIdGen
262+ -> EnvRefCache
264263 -> SmallMutableArray RealWorld Any
265264 -> SmallMutableArray RealWorld Any
266265 -> Int
267266 -> IO ()
268−relinkData gref gen store es fs = \case
267+relinkData gen cache es fs = \case
269268 0 -> pure ()
270269 n -> do
271270 let i = n - 1
@@ -273,46 +272,29 @@ relinkData gref gen store es fs = \case
273272 readSmallArray es i
274273 >>= f relinkEnv . fromAny
275274 >>= writeSmallArray es i . toAny
276− relinkData gref gen store es fs i
275+ relinkData gen cache es fs i
277276 where
278277 relinkEnv :: Env es -> IO (Env es)
279− relinkEnv (Env forks _ _) = Env <$> relinkForks gref gen store forks
280− <*> pure gref
281− <*> pure gen
278+ relinkEnv (Env forks _ _) = do
279+ Just gref <- M.lookup globalFid <$> readIORef cache
280+ Env <$> relinkForks gen cache forks <*> pure gref <*> pure gen
282281
283−relinkForks :: IORef EnvRef -> ForkIdGen -> EnvRefStore -> Forks -> IO Forks
284−relinkForks gref gen store = \case
282+relinkForks :: ForkIdGen -> EnvRefCache -> Forks -> IO Forks
283+relinkForks gen cache = \case
285284 NoFork -> pure NoFork
286285 Forks fid baseIx lref0 forks -> do
287286 -- A specific IORef EnvRef can be held by more than one local environment
288287 -- and we need to replace all its occurences with the same, new value
289288 -- containing its clone.
290− readIORef store >>= pure . IM.lookup (unForkId fid) >>= \case
289+ readIORef cache >>= pure . M.lookup fid >>= \case
291290 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
291+ <*> relinkForks gen cache forks
292+ Nothing -> Forks fid baseIx <$> cloneEnvRef gen cache fid lref0
293+ <*> relinkForks gen cache forks
312294
313295----------------------------------------
314296
315−-- | Create a local fork of the environment for handlers.
297+-- | Create a local fork of the environment for interpreters.
316298forkEnv :: Env es -> IO (Env es)
317299forkEnv env@(Env NoFork gref gen) = do
318300 size <- sizeEnv env
@@ -338,6 +320,12 @@ sizeEnv (Env (Forks _ baseIx lref _) _ _) = do
338320 pure $ baseIx + n
339321{-# NOINLINE sizeEnv #-}
340322
323+-- | Extract a specific data type from the environment.
324+getEnv :: forall e es i. e :> es => Env es -> IO (i e)
325+getEnv env = do
326+ (i, es) <- getLocation @e env
327+ fromAny <$> readSmallArray es i
328+
341329-- | Check that the size of the environment is the same as the expected value.
342330checkSizeEnv :: Int -> Env es -> IO ()
343331checkSizeEnv k (Env NoFork ref _) = do
@@ -355,11 +343,7 @@ checkSizeEnv k (Env (Forks _ baseIx lref _) _ _) = do
355343-- Extending and shrinking
356344
357345-- | 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))
346+unsafeConsEnv :: i e -> Relinker i e -> Env es -> IO (Env (e : es))
363347unsafeConsEnv e f (Env fork gref gen) = case fork of
364348 NoFork -> do
365349 extendEnvRef gref
@@ -380,10 +364,10 @@ unsafeConsEnv e f (Env fork gref gen) = case fork of
380364 writeIORef ref $! EnvRef (n + 1) es0 fs0
381365 EQ -> do
382366 let len = doubleCapacity len0
383− es <- newSmallArray len undefinedData
367+ es <- newSmallArray len (error "undefined field")
384368 copySmallMutableArray es 0 es0 0 len0
385369 e `seq` writeSmallArray es n (toAny e)
386− fs <- newSmallArray len undefinedData
370+ fs <- newSmallArray len (error "undefined field")
387371 copySmallMutableArray fs 0 fs0 0 len0
388372 f `seq` writeSmallArray fs n (toAny f)
389373 writeIORef ref $! EnvRef (n + 1) es fs
@@ -394,13 +378,14 @@ unsafeConsEnv e f (Env fork gref gen) = case fork of
394378
395379-- | Shrink the environment by one data type (in place). Makes sure the size of
396380-- 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
381+unsafeTailEnv :: Int -> Env (e : es) -> IO (Env es)
382+unsafeTailEnv len (Env fork gref gen) = case fork of
383+ NoFork -> do
384+ shrinkEnvRef len gref
385+ pure $ Env NoFork gref gen
386+ Forks _ baseIx lref _ -> do
387+ shrinkEnvRef (len - baseIx) lref
388+ pure $ Env fork gref gen
404389 where
405390 shrinkEnvRef :: Int -> IORef EnvRef -> IO ()
406391 shrinkEnvRef k ref = do
@@ -408,109 +393,81 @@ unsafeTailEnv len (Env fork gref _) = case fork of
408393 if k /= n - 1
409394 then error $ "k (" ++ show k ++ ") /= n - 1 (" ++ show (n - 1) ++ ")"
410395 else do
411− writeSmallArray es k undefinedData
412− writeSmallArray fs k undefinedData
396+ writeSmallArray es k (error "undefined field")
397+ writeSmallArray fs k (error "undefined field")
413398 writeIORef ref $! EnvRef k es fs
414399{-# NOINLINE unsafeTailEnv #-}
415400
416401----------------------------------------
417402-- Data retrieval and update
418403
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−
428404-- | 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
405+unsafePutEnv :: forall e es i. e :> es => i e -> Env es -> IO ()
406+unsafePutEnv e env = do
407+ (i, es) <- getLocation @e env
408+ e `seq` writeSmallArray es i (toAny e)
409+
410+-- | Modify the data type in the environment (in place).
411+unsafeModifyEnv :: forall e es i. e :> es => (i e -> i e) -> Env es -> IO ()
412+unsafeModifyEnv f env = do
413+ (i, es) <- getLocation @e env
414+ e <- f . fromAny <$> readSmallArray es i
436415 e `seq` writeSmallArray es i (toAny e)
437416
438417-- | 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
418+unsafeStateEnv :: forall e es i a. e :> es => (i e -> (a, i e)) -> Env es -> IO a
419+unsafeStateEnv f env = do
420+ (i, es) <- getLocation @e env
446421 (a, e) <- f . fromAny <$> readSmallArray es i
447422 e `seq` writeSmallArray es i (toAny e)
448423 pure a
449424
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−
461425----------------------------------------
462426-- Internal helpers
463427
464−undefinedData :: HasCallStack => a
465−undefinedData = error "undefined data"
466−
467428emptyEnvRef :: IO (IORef EnvRef)
468429emptyEnvRef = do
469− es <- newSmallArray 0 undefinedData
470− fs <- newSmallArray 0 undefinedData
430+ es <- newSmallArray 0 (error "undefined field")
431+ fs <- newSmallArray 0 (error "undefined field")
471432 newIORef $ EnvRef 0 es fs
472433
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−
477434-- | Determine location of the data type in the environment.
478435getLocation
479− :: Int
480− -> Env es
481− -> IO Location
482−getLocation ixE (Env fork ref _) = do
483− EnvRef n es@(SmallMutableArray es#) _ <- readIORef ref
436+ :: forall e es. e :> es
437+ => Env es
438+ -> IO (Int, SmallMutableArray RealWorld Any)
439+getLocation (Env fork ref _) = do
440+ EnvRef n es _ <- readIORef ref
484441 -- Optimized for the common access pattern:
485442 --
486443 -- - Most application code has no access to forks, in which case we look at
487444 -- the global EnvRef.
488445 --
489− -- - Effect handlers will most likely access the newest fork with handler
490− -- specific effects for reinterpretation.
446+ -- - Interpreters will most likely access the newest fork for reinterpretation
447+ -- of effects that are there.
491448 case fork of
492− NoFork -> pure $ Location (ix n) es
449+ NoFork -> pure (ix n, es)
493450 Forks _ baseIx lref forks -> do
494451 EnvRef ln les _ <- readIORef lref
495452 let i = ix (baseIx + ln)
496453 if i >= baseIx
497− then pure $ Location (i - baseIx) les
498− else go es# i forks
454+ then pure (i - baseIx, les)
455+ else go es i forks
499456 where
500− go :: SmallMutableArray# RealWorld Any
457+ go :: SmallMutableArray RealWorld Any
501458 -> Int
502459 -> Forks
503− -> IO Location
504− go es# i = \case
505− NoFork -> pure $ Location i (SmallMutableArray es#)
460+ -> IO (Int, SmallMutableArray RealWorld Any)
461+ go es i = \case
462+ NoFork -> pure (i, es)
506463 Forks _ baseIx lref forks -> do
507464 EnvRef _ les _ <- readIORef lref
508465 if i >= baseIx
509− then pure $ Location (i - baseIx) les
510− else go es# i forks
466+ then pure (i - baseIx, les)
467+ else go es i forks
511468
512469 ix :: Int -> Int
513− ix n = n - ixE - 1
470+ ix n = n - reifyIndex @e @es - 1
514471
515472toAny :: a -> Any
516473toAny = unsafeCoerce