git.iko.soy/effectful
on master help sign in
A tiny bit more efficient getLocation
6506958Andrzej Rybczak
effectful-core/src/Effectful/Internal/Env.hs+21−16
compare with master
unifiedsplit
@@ -1,3 +1,4 @@
1+{-# LANGUAGE MagicHash #-}
1{-# OPTIONS_HADDOCK not-home #-}
2{-# OPTIONS_HADDOCK not-home #-}
2-- | The environment for the 'Effectful.Internal.Monad.Eff' monad.
3-- | The environment for the 'Effectful.Internal.Monad.Eff' monad.
3--
4--
@@ -42,7 +43,7 @@ import Control.Monad
42import Control.Monad.Primitive
43import Control.Monad.Primitive
43import Data.IORef
44import Data.IORef
44import Data.Primitive.SmallArray
45import Data.Primitive.SmallArray
45−import GHC.Exts (Any)
46+import GHC.Exts (Any, SmallMutableArray#)
46import GHC.Stack (HasCallStack)
47import GHC.Stack (HasCallStack)
47import Unsafe.Coerce
48import Unsafe.Coerce
48import qualified Data.IntMap.Strict as IM
49import qualified Data.IntMap.Strict as IM
@@ -421,7 +422,7 @@ getEnv
421 => Env es
422 => Env es
422 -> IO (adapter e)
423 -> IO (adapter e)
423getEnv env = do
424getEnv env = do
424− (i, es) <- getLocation (reifyIndex @e @es) env
425+ Location i es <- getLocation (reifyIndex @e @es) env
425 fromAny <$> readSmallArray es i
426 fromAny <$> readSmallArray es i
426
427
427-- | Replace the data type in the environment with a new value (in place).
428-- | Replace the data type in the environment with a new value (in place).
@@ -431,7 +432,7 @@ putEnv
431 -> adapter e
432 -> adapter e
432 -> IO ()
433 -> IO ()
433putEnv env e = do
434putEnv env e = do
434− (i, es) <- getLocation (reifyIndex @e @es) env
435+ Location i es <- getLocation (reifyIndex @e @es) env
435 e `seq` writeSmallArray es i (toAny e)
436 e `seq` writeSmallArray es i (toAny e)
436
437
437-- | Modify the data type in the environment (in place) and return a value.
438-- | Modify the data type in the environment (in place) and return a value.
@@ -441,7 +442,7 @@ stateEnv
441 -> (adapter e -> (a, adapter e))
442 -> (adapter e -> (a, adapter e))
442 -> IO a
443 -> IO a
443stateEnv env f = do
444stateEnv env f = do
444− (i, es) <- getLocation (reifyIndex @e @es) env
445+ Location i es <- getLocation (reifyIndex @e @es) env
445 (a, e) <- f . fromAny <$> readSmallArray es i
446 (a, e) <- f . fromAny <$> readSmallArray es i
446 e `seq` writeSmallArray es i (toAny e)
447 e `seq` writeSmallArray es i (toAny e)
447 pure a
448 pure a
@@ -453,7 +454,7 @@ modifyEnv
453 -> (adapter e -> adapter e)
454 -> (adapter e -> adapter e)
454 -> IO ()
455 -> IO ()
455modifyEnv env f = do
456modifyEnv env f = do
456− (i, es) <- getLocation (reifyIndex @e @es) env
457+ Location i es <- getLocation (reifyIndex @e @es) env
457 e <- f . fromAny <$> readSmallArray es i
458 e <- f . fromAny <$> readSmallArray es i
458 e `seq` writeSmallArray es i (toAny e)
459 e `seq` writeSmallArray es i (toAny e)
459
460
@@ -469,13 +470,17 @@ emptyEnvRef = do
469 fs <- newSmallArray 0 undefinedData
470 fs <- newSmallArray 0 undefinedData
470 newIORef $ EnvRef 0 es fs
471 newIORef $ EnvRef 0 es fs
471
472
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+
472-- | Determine location of the data type in the environment.
477-- | Determine location of the data type in the environment.
473getLocation
478getLocation
474 :: Int
479 :: Int
475 -> Env es
480 -> Env es
476− -> IO (Int, SmallMutableArray RealWorld Any)
481+ -> IO Location
477getLocation ixE (Env fork ref _) = do
482getLocation ixE (Env fork ref _) = do
478− EnvRef n es _ <- readIORef ref
483+ EnvRef n es@(SmallMutableArray es#) _ <- readIORef ref
479 -- Optimized for the common access pattern:
484 -- Optimized for the common access pattern:
480 --
485 --
481 -- - Most application code has no access to forks, in which case we look at
486 -- - Most application code has no access to forks, in which case we look at
@@ -484,25 +489,25 @@ getLocation ixE (Env fork ref _) = do
484 -- - Effect handlers will most likely access the newest fork with handler
489 -- - Effect handlers will most likely access the newest fork with handler
485 -- specific effects for reinterpretation.
490 -- specific effects for reinterpretation.
486 case fork of
491 case fork of
487− NoFork -> pure (ix n, es)
492+ NoFork -> pure $ Location (ix n) es
488 Forks _ baseIx lref forks -> do
493 Forks _ baseIx lref forks -> do
489 EnvRef ln les _ <- readIORef lref
494 EnvRef ln les _ <- readIORef lref
490 let i = ix (baseIx + ln)
495 let i = ix (baseIx + ln)
491 if i >= baseIx
496 if i >= baseIx
492− then pure (i - baseIx, les)
497+ then pure $ Location (i - baseIx) les
493− else go es i forks
498+ else go es# i forks
494 where
499 where
495− go :: SmallMutableArray RealWorld Any
500+ go :: SmallMutableArray# RealWorld Any
496 -> Int
501 -> Int
497 -> Forks
502 -> Forks
498− -> IO (Int, SmallMutableArray RealWorld Any)
503+ -> IO Location
499− go es i = \case
504+ go es# i = \case
500− NoFork -> pure (i, es)
505+ NoFork -> pure $ Location i (SmallMutableArray es#)
501 Forks _ baseIx lref forks -> do
506 Forks _ baseIx lref forks -> do
502 EnvRef _ les _ <- readIORef lref
507 EnvRef _ les _ <- readIORef lref
503 if i >= baseIx
508 if i >= baseIx
504− then pure (i - baseIx, les)
509+ then pure $ Location (i - baseIx) les
505− else go es i forks
510+ else go es# i forks
506
511
507 ix :: Int -> Int
512 ix :: Int -> Int
508 ix n = n - ixE - 1
513 ix n = n - ixE - 1