942e612 · effectful · git.iko.soy

git.iko.soy/effectful

on master help sign in

Tidy things up

942e612Andrzej Rybczak5 years ago

src/Effectful/Internal/Env.hs+87−110

compare with master

unifiedsplit

@@ -59,11 +59,11 @@ type role Env nominal

59data Env (es :: [Effect]) = Env

60 { _forks :: Forks

61 , _globalRef :: IORef EnvRef

62− , _uniqueGen :: UniqueGen

62+ , _forkIdGen :: ForkIdGen

63 }

65-- | 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

68data EnvRef = EnvRef

69 { _capacity :: Int

@@ -74,14 +74,30 @@ data EnvRef = EnvRef

74----------------------------------------

75-- ForkId

77−data ForkId = ForkId

77+newtype ForkId = ForkId Word64

78− { baseIx :: Int

79− , unique :: Unique

80− } deriving (Eq, Ord, Show)

78+ deriving (Eq, Ord, Show)

82-- | Implicit 'ForkId' of the 'EnvRef' directly available from 'Env'.

80-- | Implicit 'ForkId' of the 'EnvRef' directly available from 'Env'.

83globalFid :: ForkId

81globalFid :: 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

101

86----------------------------------------

102----------------------------------------

87-- Relinker

103-- Relinker

@@ -94,59 +110,35 @@ newtype Relinker i (e :: Effect) where

94noRelinker :: Relinker i e

110noRelinker :: Relinker i e

95noRelinker = Relinker $ \_ -> pure

111noRelinker = Relinker $ \_ -> pure

112

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−

121----------------------------------------

113----------------------------------------

122-- Operations

114-- Operations

123

115

124-- | Create an empty environment.

116-- | Create an empty environment.

125emptyEnv :: IO (Env '[])

117emptyEnv :: IO (Env '[])

126−emptyEnv = Env NoFork <$> emptyEnvRef <*> newUniqueGen

118+emptyEnv = Env NoFork <$> emptyEnvRef <*> newForkIdGen

127

119

128-- | Clone the environment.

120-- | Clone the environment.

129cloneEnv :: Env es -> IO (Env es)

121cloneEnv :: Env es -> IO (Env es)

130−cloneEnv (Env NoFork gref0 ug0) = do

122+cloneEnv (Env NoFork gref0 gen0) = do

131− ug <- cloneUniqueGen ug0

123+ gen <- cloneForkIdGen gen0

132 cache <- newIORef M.empty

124 cache <- newIORef M.empty

133− gref <- cloneEnvRef ug cache globalFid gref0

125+ gref <- cloneEnvRef gen cache globalFid gref0

134− pure $ Env NoFork gref ug

126+ pure $ Env NoFork gref gen

135−cloneEnv (Env forks@(Forks fid lref0 _) gref0 ug0) = do

127+cloneEnv (Env forks@(Forks _ baseIx lref0 _) gref0 gen0) = do

136 EnvRef _ es0 fs0 <- readIORef gref0

128 EnvRef _ es0 fs0 <- readIORef gref0

137 EnvRef n _ _ <- readIORef lref0

129 EnvRef n _ _ <- readIORef lref0

138− let len = baseIx fid + n

130+ let len = baseIx + n

139 es <- newSmallArray len (error "undefined field")

131 es <- newSmallArray len (error "undefined field")

140 fs <- newSmallArray len (error "undefined field")

132 fs <- newSmallArray len (error "undefined field")

141 baseN <- copyForks es fs len forks

133 baseN <- copyForks es fs len forks

142 copySmallMutableArray es 0 es0 0 baseN

134 copySmallMutableArray es 0 es0 0 baseN

143 copySmallMutableArray fs 0 fs0 0 baseN

135 copySmallMutableArray fs 0 fs0 0 baseN

144− ug <- cloneUniqueGen ug0

136+ gen <- cloneForkIdGen gen0

145 gref <- newIORef $ EnvRef len es fs

137 gref <- newIORef $ EnvRef len es fs

146 cache <- newIORef $ M.singleton globalFid gref

138 cache <- newIORef $ M.singleton globalFid gref

147− relinkData ug cache es fs n

139+ relinkData gen cache es fs n

148 -- The forked environment is flattened and becomes the global one.

140 -- The forked environment is flattened and becomes the global one.

149− pure $ Env NoFork gref ug

141+ pure $ Env NoFork gref gen

150{-# NOINLINE cloneEnv #-}

142{-# NOINLINE cloneEnv #-}

151

143

152----------------------------------------

144----------------------------------------

@@ -158,9 +150,9 @@ cloneEnv (Env forks@(Forks fid lref0 _) gref0 ug0) = do

158--

150--

159-- Then forks will look like this:

151-- Then forks will look like this:

160--

152--

161−-- Fork (baseIx: 10, unique: ...) [10,11]

153+-- Fork (baseIx: 10, ...) [10,11]

162−-- (Fork (baseIx: 6, unique: ...) [6,7,8,9,..]

154+-- (Fork (baseIx: 6, ...) [6,7,8,9,..]

163−-- (Fork (baseIx: 2, unique: ...) [2,3,4,5,..]

155+-- (Fork (baseIx: 2, ...) [2,3,4,5,..]

164-- NoFork))

156-- NoFork))

165--

157--

166-- and elements [0,1] are taken from the global environment ([0,1,..]).

158-- and elements [0,1] are taken from the global environment ([0,1,..]).

@@ -187,40 +179,40 @@ copyForks

187 -> IO Int

179 -> IO Int

188copyForks es fs len = \case

180copyForks es fs len = \case

189 NoFork -> pure len

181 NoFork -> pure len

190− Forks fid lref0 forks -> do

182+ Forks _ baseIx lref0 forks -> do

191 EnvRef _ es0 fs0 <- readIORef lref0

183 EnvRef _ es0 fs0 <- readIORef lref0

192− let n = len - baseIx fid

184+ let n = len - baseIx

193− copySmallMutableArray es (baseIx fid) es0 0 n

185+ copySmallMutableArray es baseIx es0 0 n

194− copySmallMutableArray fs (baseIx fid) fs0 0 n

186+ copySmallMutableArray fs baseIx fs0 0 n

195− copyForks es fs (baseIx fid) forks

187+ copyForks es fs baseIx forks

196

188

197type EnvRefCache = IORef (M.Map ForkId (IORef EnvRef))

189type EnvRefCache = IORef (M.Map ForkId (IORef EnvRef))

198

190

199-- | Clone the 'EnvRef' and put it in a cache.

191-- | Clone the 'EnvRef' and put it in a cache.

200cloneEnvRef

192cloneEnvRef

201− :: UniqueGen

193+ :: ForkIdGen

202 -> EnvRefCache

194 -> EnvRefCache

203 -> ForkId

195 -> ForkId

204 -> IORef EnvRef

196 -> IORef EnvRef

205 -> IO (IORef EnvRef)

197 -> IO (IORef EnvRef)

206−cloneEnvRef ug cache fid ref0 = do

198+cloneEnvRef gen cache fid ref0 = do

207 EnvRef n es0 fs0 <- readIORef ref0

199 EnvRef n es0 fs0 <- readIORef ref0

208 es <- cloneSmallMutableArray es0 0 (sizeofSmallMutableArray es0)

200 es <- cloneSmallMutableArray es0 0 (sizeofSmallMutableArray es0)

209 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)

201 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)

210 ref <- newIORef $ EnvRef n es fs

202 ref <- newIORef $ EnvRef n es fs

211 modifyIORef' cache $ M.insert fid ref

203 modifyIORef' cache $ M.insert fid ref

212− relinkData ug cache es fs n

204+ relinkData gen cache es fs n

213 pure ref

205 pure ref

214

206

215-- | Relink local environments hiding in the interpreters.

207-- | Relink local environments hiding in the interpreters.

216relinkData

208relinkData

217− :: UniqueGen

209+ :: ForkIdGen

218 -> EnvRefCache

210 -> EnvRefCache

219 -> SmallMutableArray RealWorld Any

211 -> SmallMutableArray RealWorld Any

220 -> SmallMutableArray RealWorld Any

212 -> SmallMutableArray RealWorld Any

221 -> Int

213 -> Int

222 -> IO ()

214 -> IO ()

223−relinkData ug cache es fs = \case

215+relinkData gen cache es fs = \case

224 0 -> pure ()

216 0 -> pure ()

225 n -> do

217 n -> do

226 let i = n - 1

218 let i = n - 1

@@ -228,57 +220,42 @@ relinkData ug cache es fs = \case

228 readSmallArray es i

220 readSmallArray es i

229 >>= f relinkEnv . fromAny

221 >>= f relinkEnv . fromAny

230 >>= writeSmallArray es i . toAny

222 >>= writeSmallArray es i . toAny

231− relinkData ug cache es fs i

223+ relinkData gen cache es fs i

232 where

224 where

233 relinkEnv :: Env es -> IO (Env es)

225 relinkEnv :: Env es -> IO (Env es)

234 relinkEnv (Env forks _ _) = do

226 relinkEnv (Env forks _ _) = do

235 Just gref <- M.lookup globalFid <$> readIORef cache

227 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

237

229

238−relinkForks :: UniqueGen -> EnvRefCache -> Forks -> IO Forks

230+relinkForks :: ForkIdGen -> EnvRefCache -> Forks -> IO Forks

239−relinkForks ug cache = \case

231+relinkForks gen cache = \case

240 NoFork -> pure NoFork

232 NoFork -> pure NoFork

241− Forks fid lref0 forks -> do

233+ Forks fid baseIx lref0 forks -> do

242 -- A specific IORef EnvRef can be held by more than one local environment

234 -- A specific IORef EnvRef can be held by more than one local environment

243 -- and we need to replace all its occurences with the same, new value

235 -- and we need to replace all its occurences with the same, new value

244 -- containing its clone.

236 -- containing its clone.

245 readIORef cache >>= pure . M.lookup fid >>= \case

237 readIORef cache >>= pure . M.lookup fid >>= \case

246− Just lref -> Forks fid <$> pure lref

238+ Just lref -> Forks fid baseIx <$> pure lref

247− <*> relinkForks ug cache forks

239+ <*> relinkForks gen cache forks

248− Nothing -> Forks fid <$> cloneEnvRef ug cache fid lref0

240+ Nothing -> Forks fid baseIx <$> cloneEnvRef gen cache fid lref0

249− <*> relinkForks ug cache forks

241+ <*> relinkForks gen cache forks

250

242

251----------------------------------------

243----------------------------------------

252

244

253-- | Create a local fork of the environment for interpreters.

245-- | Create a local fork of the environment for interpreters.

254forkEnv :: Env es -> IO (Env es)

246forkEnv :: Env es -> IO (Env es)

255−forkEnv env@(Env NoFork gref ug) = do

247+forkEnv env@(Env NoFork gref gen) = do

256 size <- sizeEnv env

248 size <- sizeEnv env

257− uniq <- getUnique ug

249+ fid <- newForkId gen

258− let fid = ForkId

259− { baseIx = size

260− , unique = uniq

261− }

262− Env <$> (Forks fid <$> emptyEnvRef <*> pure NoFork)

250+ Env <$> (Forks fid size <$> emptyEnvRef <*> pure NoFork)

263− <*> pure gref <*> pure ug

251+ <*> pure gref <*> pure gen

264−forkEnv (Env forks@(Forks fid0 lref0 olderForks) gref ug) = do

252+forkEnv (Env forks@(Forks _ baseIx lref0 olderForks) gref gen) = do

253+ fid <- newForkId gen

254+ lref <- emptyEnvRef

265− EnvRef n _ _ <- readIORef lref0

255+ (_capacity <$> readIORef lref0) >>= \case

266− uniq <- getUnique ug

267− -- If the fork is empty, replace it as no data is lost.

256+ -- 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

257+ 0 -> pure $ Env (Forks fid baseIx lref olderForks) gref gen

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

258+ _ -> pure $ Env (Forks fid baseIx lref forks) gref gen

282{-# NOINLINE forkEnv #-}

259{-# NOINLINE forkEnv #-}

283

260

284-- | Get the current size of the environment.

261-- | Get the current size of the environment.

@@ -286,9 +263,9 @@ sizeEnv :: Env es -> IO Int

286sizeEnv (Env NoFork ref _) = do

263sizeEnv (Env NoFork ref _) = do

287 EnvRef n _ _ <- readIORef ref

264 EnvRef n _ _ <- readIORef ref

288 pure n

265 pure n

289−sizeEnv (Env (Forks fid lref _) _ _) = do

266+sizeEnv (Env (Forks _ baseIx lref _) _ _) = do

290 EnvRef n _ _ <- readIORef lref

267 EnvRef n _ _ <- readIORef lref

291− pure $ baseIx fid + n

268+ pure $ baseIx + n

292{-# NOINLINE sizeEnv #-}

269{-# NOINLINE sizeEnv #-}

293

270

294-- | Extract a specific data type from the environment.

271-- | Extract a specific data type from the environment.

@@ -303,11 +280,11 @@ checkSizeEnv k (Env NoFork ref _) = do

303 EnvRef n _ _ <- readIORef ref

280 EnvRef n _ _ <- readIORef ref

304 when (k /= n) $ do

281 when (k /= n) $ do

305 error $ "k (" ++ show k ++ ") /= n (" ++ show n ++ ")"

282 error $ "k (" ++ show k ++ ") /= n (" ++ show n ++ ")"

306−checkSizeEnv k (Env (Forks fid lref _) _ _) = do

283+checkSizeEnv k (Env (Forks _ baseIx lref _) _ _) = do

307 EnvRef n _ _ <- readIORef lref

284 EnvRef n _ _ <- readIORef lref

308− when (k /= baseIx fid + n) $ do

285+ when (k /= baseIx + n) $ do

309 error $ "k (" ++ show k ++ ") /= baseIx + n (baseIx: "

286 error $ "k (" ++ show k ++ ") /= baseIx + n (baseIx: "

310− ++ show (baseIx fid) ++ ", n: " ++ show n ++ ")"

287+ ++ show baseIx ++ ", n: " ++ show n ++ ")"

311{-# NOINLINE checkSizeEnv #-}

288{-# NOINLINE checkSizeEnv #-}

312

289

313----------------------------------------

290----------------------------------------

@@ -315,13 +292,13 @@ checkSizeEnv k (Env (Forks fid lref _) _ _) = do

315

292

316-- | Extend the environment with a new data type (in place).

293-- | Extend the environment with a new data type (in place).

317unsafeConsEnv :: i e -> Relinker i e -> Env es -> IO (Env (e : es))

294unsafeConsEnv :: 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

319 NoFork -> do

296 NoFork -> do

320 extendEnvRef gref

297 extendEnvRef gref

321− pure $ Env NoFork gref ug

298+ pure $ Env NoFork gref gen

322− Forks base lref forks -> do

299+ Forks _ _ lref _ -> do

323 extendEnvRef lref

300 extendEnvRef lref

324− pure $ Env (Forks base lref forks) gref ug

301+ pure $ Env fork gref gen

325 where

302 where

326 extendEnvRef :: IORef EnvRef -> IO ()

303 extendEnvRef :: IORef EnvRef -> IO ()

327 extendEnvRef ref = do

304 extendEnvRef ref = do

@@ -350,13 +327,13 @@ unsafeConsEnv e f (Env fork gref ug) = case fork of

350-- | Shrink the environment by one data type (in place). Makes sure the size of

327-- | Shrink the environment by one data type (in place). Makes sure the size of

351-- the environment is as expected.

328-- the environment is as expected.

352unsafeTailEnv :: Int -> Env (e : es) -> IO (Env es)

329unsafeTailEnv :: 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

354 NoFork -> do

331 NoFork -> do

355 shrinkEnvRef len gref

332 shrinkEnvRef len gref

356− pure $ Env NoFork gref ug

333+ pure $ Env NoFork gref gen

357− Forks fid lref forks -> do

334+ Forks _ baseIx lref _ -> do

358− shrinkEnvRef (len - baseIx fid) lref

335+ shrinkEnvRef (len - baseIx) lref

359− pure $ Env (Forks fid lref forks) gref ug

336+ pure $ Env fork gref gen

360 where

337 where

361 shrinkEnvRef :: Int -> IORef EnvRef -> IO ()

338 shrinkEnvRef :: Int -> IORef EnvRef -> IO ()

362 shrinkEnvRef k ref = do

339 shrinkEnvRef k ref = do

@@ -418,11 +395,11 @@ getLocation (Env fork ref _) = do

418 -- of effects that are there.

395 -- of effects that are there.

419 case fork of

396 case fork of

420 NoFork -> pure (ix n, es)

397 NoFork -> pure (ix n, es)

421− Forks fid lref forks -> do

398+ Forks _ baseIx lref forks -> do

422 EnvRef ln les _ <- readIORef lref

399 EnvRef ln les _ <- readIORef lref

423− let i = ix (baseIx fid + ln)

400+ let i = ix (baseIx + ln)

424− if i >= baseIx fid

401+ if i >= baseIx

425− then pure (i - baseIx fid, les)

402+ then pure (i - baseIx, les)

426 else go es i forks

403 else go es i forks

427 where

404 where

428 go :: SmallMutableArray RealWorld Any

405 go :: SmallMutableArray RealWorld Any

@@ -431,10 +408,10 @@ getLocation (Env fork ref _) = do

431 -> IO (Int, SmallMutableArray RealWorld Any)

408 -> IO (Int, SmallMutableArray RealWorld Any)

432 go es i = \case

409 go es i = \case

433 NoFork -> pure (i, es)

410 NoFork -> pure (i, es)

434− Forks fid lref forks -> do

411+ Forks _ baseIx lref forks -> do

435 EnvRef _ les _ <- readIORef lref

412 EnvRef _ les _ <- readIORef lref

436− if i >= baseIx fid

413+ if i >= baseIx

437− then pure (i - baseIx fid, les)

414+ then pure (i - baseIx, les)

438 else go es i forks

415 else go es i forks

439

416

440 ix :: Int -> Int

417 ix :: Int -> Int