@@ -59,11 +59,11 @@ type role Env nominal
5959data Env (es :: [Effect]) = Env
6060 { _forks :: Forks
6161 , _globalRef :: IORef EnvRef
62− , _uniqueGen :: UniqueGen
62+ , _forkIdGen :: ForkIdGen
6363 }
6464
6565-- | Local forks of the environment.
66−data Forks = Forks {-# UNPACK #-} ForkId (IORef EnvRef) Forks | NoFork
66+data Forks = Forks ForkId Int (IORef EnvRef) Forks | NoFork
6767
6868data EnvRef = EnvRef
6969 { _capacity :: Int
@@ -74,14 +74,30 @@ data EnvRef = EnvRef
7474----------------------------------------
7575-- ForkId
7676
77−data ForkId = ForkId
78− { baseIx :: Int
79− , unique :: Unique
80− } deriving (Eq, Ord, Show)
77+newtype ForkId = ForkId Word64
78+ deriving (Eq, Ord, Show)
8179
8280-- | Implicit 'ForkId' of the 'EnvRef' directly available from 'Env'.
8381globalFid :: ForkId
84−globalFid = ForkId 0 (Unique 0)
82+globalFid = ForkId 0
83+
84+-- | 'ForkId' generation.
85+newtype ForkIdGen = ForkIdGen (IORef ForkId)
86+
87+-- | Create a new thread local unique generator.
88+newForkIdGen :: IO ForkIdGen
89+newForkIdGen = ForkIdGen <$> newIORef (ForkId 1)
90+
91+-- | Clone the unique generator for use in a different thread.
92+cloneForkIdGen :: ForkIdGen -> IO ForkIdGen
93+cloneForkIdGen (ForkIdGen ref) = fmap ForkIdGen . newIORef =<< readIORef ref
94+
95+-- | Get a unique 'ForkId' from the generator.
96+newForkId :: ForkIdGen -> IO ForkId
97+newForkId (ForkIdGen ref) = do
98+ fid@(ForkId n) <- readIORef ref
99+ writeIORef ref $! ForkId (n + 1)
100+ pure fid
85101
86102----------------------------------------
87103-- Relinker
@@ -94,59 +110,35 @@ newtype Relinker i (e :: Effect) where
94110noRelinker :: Relinker i e
95111noRelinker = Relinker $ \_ -> pure
96112
97−----------------------------------------
98−-- UniqueGen
99−
100−newtype Unique = Unique Word64
101− deriving (Eq, Ord, Show)
102−
103−-- | Uniques for 'ForkId'S.
104−newtype UniqueGen = UniqueGen (IORef Unique)
105−
106−-- | Create a new thread local unique generator.
107−newUniqueGen :: IO UniqueGen
108−newUniqueGen = UniqueGen <$> newIORef (Unique 1)
109−
110−-- | Clone the unique generator for use in a different thread.
111−cloneUniqueGen :: UniqueGen -> IO UniqueGen
112−cloneUniqueGen (UniqueGen ref) = fmap UniqueGen . newIORef =<< readIORef ref
113−
114−-- | Get a 'Unique' from the generator.
115−getUnique :: UniqueGen -> IO Unique
116−getUnique (UniqueGen ref) = do
117− unique@(Unique n) <- readIORef ref
118− writeIORef ref $! Unique (n + 1)
119− pure unique
120−
121113----------------------------------------
122114-- Operations
123115
124116-- | Create an empty environment.
125117emptyEnv :: IO (Env '[])
126−emptyEnv = Env NoFork <$> emptyEnvRef <*> newUniqueGen
118+emptyEnv = Env NoFork <$> emptyEnvRef <*> newForkIdGen
127119
128120-- | Clone the environment.
129121cloneEnv :: Env es -> IO (Env es)
130−cloneEnv (Env NoFork gref0 ug0) = do
131− ug <- cloneUniqueGen ug0
122+cloneEnv (Env NoFork gref0 gen0) = do
123+ gen <- cloneForkIdGen gen0
132124 cache <- newIORef M.empty
133− gref <- cloneEnvRef ug cache globalFid gref0
134− pure $ Env NoFork gref ug
135−cloneEnv (Env forks@(Forks fid lref0 _) gref0 ug0) = do
125+ gref <- cloneEnvRef gen cache globalFid gref0
126+ pure $ Env NoFork gref gen
127+cloneEnv (Env forks@(Forks _ baseIx lref0 _) gref0 gen0) = do
136128 EnvRef _ es0 fs0 <- readIORef gref0
137129 EnvRef n _ _ <- readIORef lref0
138− let len = baseIx fid + n
130+ let len = baseIx + n
139131 es <- newSmallArray len (error "undefined field")
140132 fs <- newSmallArray len (error "undefined field")
141133 baseN <- copyForks es fs len forks
142134 copySmallMutableArray es 0 es0 0 baseN
143135 copySmallMutableArray fs 0 fs0 0 baseN
144− ug <- cloneUniqueGen ug0
136+ gen <- cloneForkIdGen gen0
145137 gref <- newIORef $ EnvRef len es fs
146138 cache <- newIORef $ M.singleton globalFid gref
147− relinkData ug cache es fs n
139+ relinkData gen cache es fs n
148140 -- The forked environment is flattened and becomes the global one.
149− pure $ Env NoFork gref ug
141+ pure $ Env NoFork gref gen
150142{-# NOINLINE cloneEnv #-}
151143
152144----------------------------------------
@@ -158,9 +150,9 @@ cloneEnv (Env forks@(Forks fid lref0 _) gref0 ug0) = do
158150--
159151-- Then forks will look like this:
160152--
161−-- Fork (baseIx: 10, unique: ...) [10,11]
162−-- (Fork (baseIx: 6, unique: ...) [6,7,8,9,..]
163−-- (Fork (baseIx: 2, unique: ...) [2,3,4,5,..]
153+-- Fork (baseIx: 10, ...) [10,11]
154+-- (Fork (baseIx: 6, ...) [6,7,8,9,..]
155+-- (Fork (baseIx: 2, ...) [2,3,4,5,..]
164156-- NoFork))
165157--
166158-- and elements [0,1] are taken from the global environment ([0,1,..]).
@@ -187,40 +179,40 @@ copyForks
187179 -> IO Int
188180copyForks es fs len = \case
189181 NoFork -> pure len
190− Forks fid lref0 forks -> do
182+ Forks _ baseIx lref0 forks -> do
191183 EnvRef _ es0 fs0 <- readIORef lref0
192− let n = len - baseIx fid
193− copySmallMutableArray es (baseIx fid) es0 0 n
194− copySmallMutableArray fs (baseIx fid) fs0 0 n
195− copyForks es fs (baseIx fid) forks
184+ let n = len - baseIx
185+ copySmallMutableArray es baseIx es0 0 n
186+ copySmallMutableArray fs baseIx fs0 0 n
187+ copyForks es fs baseIx forks
196188
197189type EnvRefCache = IORef (M.Map ForkId (IORef EnvRef))
198190
199191-- | Clone the 'EnvRef' and put it in a cache.
200192cloneEnvRef
201− :: UniqueGen
193+ :: ForkIdGen
202194 -> EnvRefCache
203195 -> ForkId
204196 -> IORef EnvRef
205197 -> IO (IORef EnvRef)
206−cloneEnvRef ug cache fid ref0 = do
198+cloneEnvRef gen cache fid ref0 = do
207199 EnvRef n es0 fs0 <- readIORef ref0
208200 es <- cloneSmallMutableArray es0 0 (sizeofSmallMutableArray es0)
209201 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)
210202 ref <- newIORef $ EnvRef n es fs
211203 modifyIORef' cache $ M.insert fid ref
212− relinkData ug cache es fs n
204+ relinkData gen cache es fs n
213205 pure ref
214206
215207-- | Relink local environments hiding in the interpreters.
216208relinkData
217− :: UniqueGen
209+ :: ForkIdGen
218210 -> EnvRefCache
219211 -> SmallMutableArray RealWorld Any
220212 -> SmallMutableArray RealWorld Any
221213 -> Int
222214 -> IO ()
223−relinkData ug cache es fs = \case
215+relinkData gen cache es fs = \case
224216 0 -> pure ()
225217 n -> do
226218 let i = n - 1
@@ -228,57 +220,42 @@ relinkData ug cache es fs = \case
228220 readSmallArray es i
229221 >>= f relinkEnv . fromAny
230222 >>= writeSmallArray es i . toAny
231− relinkData ug cache es fs i
223+ relinkData gen cache es fs i
232224 where
233225 relinkEnv :: Env es -> IO (Env es)
234226 relinkEnv (Env forks _ _) = do
235227 Just gref <- M.lookup globalFid <$> readIORef cache
236− Env <$> relinkForks ug cache forks <*> pure gref <*> pure ug
228+ Env <$> relinkForks gen cache forks <*> pure gref <*> pure gen
237229
238−relinkForks :: UniqueGen -> EnvRefCache -> Forks -> IO Forks
239−relinkForks ug cache = \case
230+relinkForks :: ForkIdGen -> EnvRefCache -> Forks -> IO Forks
231+relinkForks gen cache = \case
240232 NoFork -> pure NoFork
241− Forks fid lref0 forks -> do
233+ Forks fid baseIx lref0 forks -> do
242234 -- A specific IORef EnvRef can be held by more than one local environment
243235 -- and we need to replace all its occurences with the same, new value
244236 -- containing its clone.
245237 readIORef cache >>= pure . M.lookup fid >>= \case
246− Just lref -> Forks fid <$> pure lref
247− <*> relinkForks ug cache forks
248− Nothing -> Forks fid <$> cloneEnvRef ug cache fid lref0
249− <*> relinkForks ug cache forks
238+ Just lref -> Forks fid baseIx <$> pure lref
239+ <*> relinkForks gen cache forks
240+ Nothing -> Forks fid baseIx <$> cloneEnvRef gen cache fid lref0
241+ <*> relinkForks gen cache forks
250242
251243----------------------------------------
252244
253245-- | Create a local fork of the environment for interpreters.
254246forkEnv :: Env es -> IO (Env es)
255−forkEnv env@(Env NoFork gref ug) = do
247+forkEnv env@(Env NoFork gref gen) = do
256248 size <- sizeEnv env
257− uniq <- getUnique ug
258− let fid = ForkId
259− { baseIx = size
260− , unique = uniq
261− }
262− Env <$> (Forks fid <$> emptyEnvRef <*> pure NoFork)
263− <*> pure gref <*> pure ug
264−forkEnv (Env forks@(Forks fid0 lref0 olderForks) gref ug) = do
265− EnvRef n _ _ <- readIORef lref0
266− uniq <- getUnique ug
267− -- If the fork is empty, replace it as no data is lost.
268− if n == 0
269− then do
270− lref <- emptyEnvRef
271− let fid = fid0
272− { unique = uniq
273− }
274− pure $ Env (Forks fid lref olderForks) gref ug
275− else do
276− lref <- emptyEnvRef
277− let fid = fid0
278− { baseIx = baseIx fid0 + n
279− , unique = uniq
280− }
281− pure $ Env (Forks fid lref forks) gref ug
249+ fid <- newForkId gen
250+ Env <$> (Forks fid size <$> emptyEnvRef <*> pure NoFork)
251+ <*> pure gref <*> pure gen
252+forkEnv (Env forks@(Forks _ baseIx lref0 olderForks) gref gen) = do
253+ fid <- newForkId gen
254+ lref <- emptyEnvRef
255+ (_capacity <$> readIORef lref0) >>= \case
256+ -- If the fork is empty, replace it as no data is lost.
257+ 0 -> pure $ Env (Forks fid baseIx lref olderForks) gref gen
258+ _ -> pure $ Env (Forks fid baseIx lref forks) gref gen
282259{-# NOINLINE forkEnv #-}
283260
284261-- | Get the current size of the environment.
@@ -286,9 +263,9 @@ sizeEnv :: Env es -> IO Int
286263sizeEnv (Env NoFork ref _) = do
287264 EnvRef n _ _ <- readIORef ref
288265 pure n
289−sizeEnv (Env (Forks fid lref _) _ _) = do
266+sizeEnv (Env (Forks _ baseIx lref _) _ _) = do
290267 EnvRef n _ _ <- readIORef lref
291− pure $ baseIx fid + n
268+ pure $ baseIx + n
292269{-# NOINLINE sizeEnv #-}
293270
294271-- | Extract a specific data type from the environment.
@@ -303,11 +280,11 @@ checkSizeEnv k (Env NoFork ref _) = do
303280 EnvRef n _ _ <- readIORef ref
304281 when (k /= n) $ do
305282 error $ "k (" ++ show k ++ ") /= n (" ++ show n ++ ")"
306−checkSizeEnv k (Env (Forks fid lref _) _ _) = do
283+checkSizeEnv k (Env (Forks _ baseIx lref _) _ _) = do
307284 EnvRef n _ _ <- readIORef lref
308− when (k /= baseIx fid + n) $ do
285+ when (k /= baseIx + n) $ do
309286 error $ "k (" ++ show k ++ ") /= baseIx + n (baseIx: "
310− ++ show (baseIx fid) ++ ", n: " ++ show n ++ ")"
287+ ++ show baseIx ++ ", n: " ++ show n ++ ")"
311288{-# NOINLINE checkSizeEnv #-}
312289
313290----------------------------------------
@@ -315,13 +292,13 @@ checkSizeEnv k (Env (Forks fid lref _) _ _) = do
315292
316293-- | Extend the environment with a new data type (in place).
317294unsafeConsEnv :: i e -> Relinker i e -> Env es -> IO (Env (e : es))
318−unsafeConsEnv e f (Env fork gref ug) = case fork of
295+unsafeConsEnv e f (Env fork gref gen) = case fork of
319296 NoFork -> do
320297 extendEnvRef gref
321− pure $ Env NoFork gref ug
322− Forks base lref forks -> do
298+ pure $ Env NoFork gref gen
299+ Forks _ _ lref _ -> do
323300 extendEnvRef lref
324− pure $ Env (Forks base lref forks) gref ug
301+ pure $ Env fork gref gen
325302 where
326303 extendEnvRef :: IORef EnvRef -> IO ()
327304 extendEnvRef ref = do
@@ -350,13 +327,13 @@ unsafeConsEnv e f (Env fork gref ug) = case fork of
350327-- | Shrink the environment by one data type (in place). Makes sure the size of
351328-- the environment is as expected.
352329unsafeTailEnv :: Int -> Env (e : es) -> IO (Env es)
353−unsafeTailEnv len (Env fork gref ug) = case fork of
330+unsafeTailEnv len (Env fork gref gen) = case fork of
354331 NoFork -> do
355332 shrinkEnvRef len gref
356− pure $ Env NoFork gref ug
357− Forks fid lref forks -> do
358− shrinkEnvRef (len - baseIx fid) lref
359− pure $ Env (Forks fid lref forks) gref ug
333+ pure $ Env NoFork gref gen
334+ Forks _ baseIx lref _ -> do
335+ shrinkEnvRef (len - baseIx) lref
336+ pure $ Env fork gref gen
360337 where
361338 shrinkEnvRef :: Int -> IORef EnvRef -> IO ()
362339 shrinkEnvRef k ref = do
@@ -418,11 +395,11 @@ getLocation (Env fork ref _) = do
418395 -- of effects that are there.
419396 case fork of
420397 NoFork -> pure (ix n, es)
421− Forks fid lref forks -> do
398+ Forks _ baseIx lref forks -> do
422399 EnvRef ln les _ <- readIORef lref
423− let i = ix (baseIx fid + ln)
424− if i >= baseIx fid
425− then pure (i - baseIx fid, les)
400+ let i = ix (baseIx + ln)
401+ if i >= baseIx
402+ then pure (i - baseIx, les)
426403 else go es i forks
427404 where
428405 go :: SmallMutableArray RealWorld Any
@@ -431,10 +408,10 @@ getLocation (Env fork ref _) = do
431408 -> IO (Int, SmallMutableArray RealWorld Any)
432409 go es i = \case
433410 NoFork -> pure (i, es)
434− Forks fid lref forks -> do
411+ Forks _ baseIx lref forks -> do
435412 EnvRef _ les _ <- readIORef lref
436− if i >= baseIx fid
437− then pure (i - baseIx fid, les)
413+ if i >= baseIx
414+ then pure (i - baseIx, les)
438415 else go es i forks
439416
440417 ix :: Int -> Int