@@ -1,14 +1,18 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# OPTIONS_HADDOCK not-home #-}
2{-# OPTIONS_HADDOCK not-home #-}
2−-- | The enviroment for 'Effectful.Internal.Monad.Eff'.
3+-- | The environment for 'Effectful.Internal.Monad.Eff'.
4-- This module is intended for internal use only, and may change without warning
5-- This module is intended for internal use only, and may change without warning
5-- in subsequent releases.
6-- in subsequent releases.
6module Effectful.Internal.Env
7module Effectful.Internal.Env
9 -- * Safe operations
12 -- * Safe operations
10 , emptyEnv
13 , emptyEnv
11 , cloneEnv
14 , cloneEnv
14 , checkSizeEnv
18 , checkSizeEnv
@@ -30,8 +34,9 @@ import Data.Primitive.SmallArray
30import GHC.Exts (Any)
34import GHC.Exts (Any)
31import GHC.Stack
35import GHC.Stack
32import Unsafe.Coerce
36import Unsafe.Coerce
37+import qualified Data.Map.Strict as M
34−import Effectful.Internal.Has
39+import Effectful.Internal.Effect
36type role Env nominal
41type role Env nominal
@@ -48,61 +53,192 @@ type role Env nominal
49-- - Modification of a specific element: /O(1)/.
54-- - Modification of a specific element: /O(1)/.
51−newtype Env (es :: [Effect]) = Env (IORef EnvRef)
56+data Env (es :: [Effect]) = Env Forks (IORef EnvRef)
58+-- | A fork is uniquely determined by its base index and depth.
62+ } deriving (Eq, Ord, Show)
64+-- | Implicit 'ForkId' of the 'EnvRef' directly available from 'Env'.
66+globalFid = ForkId 0 0
68+-- | Local forks of the environment.
69+data Forks = Forks ForkId (IORef EnvRef) Forks | NoFork
73+ , _data :: SmallMutableArray RealWorld Any
53−data EnvRef = EnvRef Int (SmallMutableArray RealWorld Any)
74+ , _relinkers :: SmallMutableArray RealWorld Any
77+newtype Relinker i (e :: Effect) where
79+ :: ((forall es. Env es -> IO (Env es)) -> i e -> IO (i e))
82+noRelinker :: Relinker i e
83+noRelinker = Relinker $ \_ -> pure
55-- | Create an empty environment.
85-- | Create an empty environment.
56emptyEnv :: IO (Env '[])
86emptyEnv :: IO (Env '[])
57−emptyEnv = fmap Env . newIORef . EnvRef 0
87+emptyEnv = Env NoFork <$> emptyEnvRef
58− =<< newSmallArray 0 (error "undefined field")
60-- | Clone the environment.
89-- | Clone the environment.
61−cloneEnv :: Env es -> IO (Env es)
90+cloneEnv :: HasCallStack => Env es -> IO (Env es)
62−cloneEnv (Env ref) = do
91+cloneEnv (Env NoFork gref0) = do
63− EnvRef n es <- readIORef ref
92+ cache <- newIORef M.empty
64− fmap Env . newIORef . EnvRef n
93+ gref <- cloneEnvRef cache globalFid gref0
94+ pure $ Env NoFork gref
95+cloneEnv _ = error "Cloning of forked enviroment is not supported yet"
96+{-# NOINLINE cloneEnv #-}
98+----------------------------------------
101+type EnvRefCache = IORef (M.Map ForkId (IORef EnvRef))
103+-- | Clone the 'EnvRef' and put it in a cache.
108+ -> IO (IORef EnvRef)
109+cloneEnvRef cache fid ref0 = do
110+ EnvRef n es0 fs0 <- readIORef ref0
111+ es <- cloneSmallMutableArray es0 0 (sizeofSmallMutableArray es0)
65− =<< cloneSmallMutableArray es 0 (sizeofSmallMutableArray es)
112+ fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)
113+ ref <- newIORef $ EnvRef n es fs
114+ modifyIORef' cache $ M.insert fid ref
115+ relinkData cache es fs n
118+-- | Relink local environments hiding in the interpreters.
121+ -> SmallMutableArray RealWorld Any
122+ -> SmallMutableArray RealWorld Any
125+relinkData cache es fs = \case
129+ Relinker f <- fromAny <$> readSmallArray fs i
131+ >>= f relinkEnv . fromAny
132+ >>= writeSmallArray es i . toAny
133+ relinkData cache es fs i
135+ relinkEnv :: Env es -> IO (Env es)
136+ relinkEnv (Env forks _) = do
137+ Just gref <- M.lookup globalFid <$> readIORef cache
138+ Env <$> relinkForks cache forks <*> pure gref
140+relinkForks :: EnvRefCache -> Forks -> IO Forks
141+relinkForks cache = \case
142+ NoFork -> pure NoFork
143+ Forks fid lref0 forks -> (M.lookup fid <$> readIORef cache) >>= \case
144+ Just lref -> Forks fid <$> pure lref
145+ <*> relinkForks cache forks
146+ Nothing -> Forks fid <$> cloneEnvRef cache fid lref0
147+ <*> relinkForks cache forks
149+----------------------------------------
151+-- | Create a local fork of the environment for interpreters.
152+forkEnv :: HasCallStack => Env es -> IO (Env es)
153+forkEnv env@(Env NoFork gref) = do
159+ Env <$> (Forks fid <$> emptyEnvRef <*> pure NoFork)
161+forkEnv (Env forks@(Forks fid0 lref0 olderForks) gref) = do
162+ EnvRef n _ _ <- readIORef lref0
163+ -- If the fork is empty, replace it as no data is lost.
168+ { depth = depth fid0 + 1
170+ pure $ Env (Forks fid lref olderForks) gref
174+ { baseIx = baseIx fid0 + n
175+ , depth = depth fid0 + 1
177+ pure $ Env (Forks fid lref forks) gref
178+{-# NOINLINE forkEnv #-}
67-- | Get the current size of the environment.
180-- | Get the current size of the environment.
68sizeEnv :: Env es -> IO Int
181sizeEnv :: Env es -> IO Int
69−sizeEnv (Env ref) = do
182+sizeEnv (Env NoFork ref) = do
70− EnvRef n _ <- readIORef ref
183+ EnvRef n _ _ <- readIORef ref
185+sizeEnv (Env (Forks fid lref _) _) = do
186+ EnvRef n _ _ <- readIORef lref
187+ pure $ baseIx fid + n
188+{-# NOINLINE sizeEnv #-}
73-- | Extract a specific data type from the environment.
190-- | Extract a specific data type from the environment.
74−getEnv :: forall e es. (HasCallStack, e :> es) => Env es -> IO e
191+getEnv :: forall e es i. (HasCallStack, e :> es) => Env es -> IO (i e)
75−getEnv (Env ref) = do
192+getEnv env = do
76− EnvRef n es <- readIORef ref
193+ (i, es) <- getLocation @e env
77− fromAny <$> readSmallArray es (ixEnv @e @es n)
194+ fromAny <$> readSmallArray es i
79-- | Check that the size of the environment is the same as the expected value.
196-- | Check that the size of the environment is the same as the expected value.
80checkSizeEnv :: HasCallStack => Int -> Env es -> IO ()
197checkSizeEnv :: HasCallStack => Int -> Env es -> IO ()
81−checkSizeEnv k (Env ref) = do
198+checkSizeEnv k (Env NoFork ref) = do
82− EnvRef n _ <- readIORef ref
199+ EnvRef n _ _ <- readIORef ref
201+ error $ "k (" ++ show k ++ ") /= n (" ++ show n ++ ")"
202+checkSizeEnv k (Env (Forks fid lref _) _) = do
203+ EnvRef n _ _ <- readIORef lref
204+ when (k /= baseIx fid + n) $ do
83− when (k /= n) . error $ "k (" ++ show k ++ ") /= n (" ++ show n ++ ")"
205+ error $ "k (" ++ show k ++ ") /= baseIx + n (baseIx: "
206+ ++ show (baseIx fid) ++ ", n: " ++ show n ++ ")"
207+{-# NOINLINE checkSizeEnv #-}
85----------------------------------------
209----------------------------------------
86-- Extending and shrinking
210-- Extending and shrinking
88-- | Extend the environment with a new data type (in place).
212-- | Extend the environment with a new data type (in place).
89−unsafeConsEnv :: HasCallStack => e -> Env es -> IO (Env (e : es))
213+unsafeConsEnv :: HasCallStack => i e -> Relinker i e -> Env es -> IO (Env (e : es))
90−unsafeConsEnv e (Env ref) = do
214+unsafeConsEnv e f (Env fork gref) = case fork of
91− EnvRef n es0 <- readIORef ref
215+ NoFork -> do
92− let len0 = sizeofSmallMutableArray es0
216+ extendEnvRef gref
93− case n `compare` len0 of
217+ pure $ Env NoFork gref
94− GT -> error $ "n (" ++ show n ++ ") > len0 (" ++ show len0 ++ ")"
218+ Forks base lref forks -> do
95− LT -> do
219+ extendEnvRef lref
96− e `seq` writeSmallArray es0 n (toAny e)
220+ pure $ Env (Forks base lref forks) gref
97− writeIORef ref $! EnvRef (n + 1) es0
99− let len = doubleCapacity len0
100− es <- newSmallArray len (error "undefined field")
101− copySmallMutableArray es 0 es0 0 len0
102− e `seq` writeSmallArray es n (toAny e)
103− writeIORef ref $! EnvRef (n + 1) es
222+ extendEnvRef :: IORef EnvRef -> IO ()
223+ extendEnvRef ref = do
224+ EnvRef n es0 fs0 <- readIORef ref
225+ let len0 = sizeofSmallMutableArray es0
226+ case n `compare` len0 of
227+ GT -> error $ "n (" ++ show n ++ ") > len0 (" ++ show len0 ++ ")"
229+ e `seq` writeSmallArray es0 n (toAny e)
230+ f `seq` writeSmallArray fs0 n (toAny f)
231+ writeIORef ref $! EnvRef (n + 1) es0 fs0
233+ let len = doubleCapacity len0
234+ es <- newSmallArray len (error "undefined field")
235+ copySmallMutableArray es 0 es0 0 len0
236+ e `seq` writeSmallArray es n (toAny e)
237+ fs <- newSmallArray len (error "undefined field")
238+ copySmallMutableArray fs 0 fs0 0 len0
239+ f `seq` writeSmallArray fs n (toAny f)
240+ writeIORef ref $! EnvRef (n + 1) es fs
106 doubleCapacity :: Int -> Int
242 doubleCapacity :: Int -> Int
107 doubleCapacity n = max 1 n * 2
243 doubleCapacity n = max 1 n * 2
108{-# NOINLINE unsafeConsEnv #-}
244{-# NOINLINE unsafeConsEnv #-}
@@ -110,14 +246,23 @@ unsafeConsEnv e (Env ref) = do
110-- | Shrink the environment by one data type (in place). Makes sure the size of
246-- | Shrink the environment by one data type (in place). Makes sure the size of
111-- the environment is as expected.
247-- the environment is as expected.
112unsafeTailEnv :: HasCallStack => Int -> Env (e : es) -> IO (Env es)
248unsafeTailEnv :: HasCallStack => Int -> Env (e : es) -> IO (Env es)
113−unsafeTailEnv k (Env ref) = do
249+unsafeTailEnv len (Env fork gref) = case fork of
251+ shrinkEnvRef len gref
252+ pure $ Env NoFork gref
253+ Forks fid lref forks -> do
254+ shrinkEnvRef (len - baseIx fid) lref
255+ pure $ Env (Forks fid lref forks) gref
257+ shrinkEnvRef :: Int -> IORef EnvRef -> IO ()
258+ shrinkEnvRef k ref = do
114− EnvRef n es <- readIORef ref
259+ EnvRef n es fs <- readIORef ref
115− if k /= n - 1
260+ if k /= n - 1
116− then error $ "k (" ++ show k ++ ") /= n - 1 (" ++ show (n - 1) ++ ")"
261+ then error $ "k (" ++ show k ++ ") /= n - 1 (" ++ show (n - 1) ++ ")"
118− writeSmallArray es k (error "undefined field")
263+ writeSmallArray es k (error "undefined field")
264+ writeSmallArray fs k (error "undefined field")
119− writeIORef ref $! EnvRef k es
265+ writeIORef ref $! EnvRef k es fs
121{-# NOINLINE unsafeTailEnv #-}
266{-# NOINLINE unsafeTailEnv #-}
123----------------------------------------
268----------------------------------------
@@ -125,34 +270,32 @@ unsafeTailEnv k (Env ref) = do
126-- | Replace the data type in the environment with a new value (in place).
271-- | Replace the data type in the environment with a new value (in place).
127unsafePutEnv
272unsafePutEnv
128− :: forall e es. (HasCallStack, e :> es)
273+ :: forall e es i. (HasCallStack, e :> es)
130 -> Env es
275 -> Env es
132−unsafePutEnv e (Env ref) = do
277+unsafePutEnv e env = do
133− EnvRef n es <- readIORef ref
278+ (i, es) <- getLocation @e env
134− e `seq` writeSmallArray es (ixEnv @e @es n) (toAny e)
279+ e `seq` writeSmallArray es i (toAny e)
136-- | Modify the data type in the environment (in place).
281-- | Modify the data type in the environment (in place).
137unsafeModifyEnv
282unsafeModifyEnv
138− :: forall e es. (HasCallStack, e :> es)
283+ :: forall e es i. (HasCallStack, e :> es)
139− => (e -> e)
284+ => (i e -> i e)
140 -> Env es
285 -> Env es
142−unsafeModifyEnv f (Env ref) = do
287+unsafeModifyEnv f env = do
143− EnvRef n es <- readIORef ref
288+ (i, es) <- getLocation @e env
144− let i = ixEnv @e @es n
145 e <- f . fromAny <$> readSmallArray es i
289 e <- f . fromAny <$> readSmallArray es i
146 e `seq` writeSmallArray es i (toAny e)
290 e `seq` writeSmallArray es i (toAny e)
148−-- | Modify the data type in the enviroment (in place) and return a value.
292+-- | Modify the data type in the environment (in place) and return a value.
149unsafeStateEnv
293unsafeStateEnv
150− :: forall e es a. (HasCallStack, e :> es)
294+ :: forall e es i a. (HasCallStack, e :> es)
151− => (e -> (a, e))
295+ => (i e -> (a, i e))
152 -> Env es -> IO a
296 -> Env es -> IO a
153−unsafeStateEnv f (Env ref) = do
297+unsafeStateEnv f env = do
154− EnvRef n es <- readIORef ref
298+ (i, es) <- getLocation @e env
155− let i = ixEnv @e @es n
156 (a, e) <- f . fromAny <$> readSmallArray es i
299 (a, e) <- f . fromAny <$> readSmallArray es i
157 e `seq` writeSmallArray es i (toAny e)
300 e `seq` writeSmallArray es i (toAny e)
@@ -160,6 +303,50 @@ unsafeStateEnv f (Env ref) = do
160----------------------------------------
303----------------------------------------
161-- Internal helpers
304-- Internal helpers
306+emptyEnvRef :: IO (IORef EnvRef)
308+ es <- newSmallArray 0 (error "undefined field")
309+ fs <- newSmallArray 0 (error "undefined field")
310+ newIORef $ EnvRef 0 es fs
312+-- | Determine location of the data type in the environment.
314+ :: forall e es. e :> es
316+ -> IO (Int, SmallMutableArray RealWorld Any)
317+getLocation (Env fork ref) = do
318+ EnvRef n es _ <- readIORef ref
319+ -- Optimized for the common access pattern:
321+ -- - Most application code has no access to forks, in which case we look at
322+ -- the global EnvRef.
324+ -- - Interpreters will most likely access the newest fork for reinterpretation
325+ -- of effects that are there.
327+ NoFork -> pure (ix n, es)
328+ Forks fid lref forks -> do
329+ EnvRef ln les _ <- readIORef lref
330+ let i = ix (baseIx fid + ln)
332+ then pure (i - baseIx fid, les)
335+ go :: SmallMutableArray RealWorld Any
338+ -> IO (Int, SmallMutableArray RealWorld Any)
340+ NoFork -> pure (i, es)
341+ Forks fid lref forks -> do
342+ EnvRef _ les _ <- readIORef lref
344+ then pure (i - baseIx fid, les)
348+ ix n = n - reifyIndex @e @es - 1
163toAny :: a -> Any
350toAny :: a -> Any
164toAny = unsafeCoerce
351toAny = unsafeCoerce