{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnliftedFFITypes #-}
{-# OPTIONS_HADDOCK not-home #-}
module Effectful.Internal.Utils
  ( inlineBracket

    -- * Utils for 'ThreadId'
  , weakThreadId
  , eqThreadId

    -- * Utils for 'Any'
  , Any
  , toAny
  , fromAny

    -- * Unique
  , Unique
  , newUnique

    -- * CallStack
  , thawCallStack

    -- * Array capacity
  , growCapacity
  ) where

import Control.Exception
import Data.Primitive.ByteArray
import GHC.Conc.Sync (ThreadId(..))
import GHC.Exts (Any, RealWorld)
import GHC.Stack.Types (CallStack(..))
import Unsafe.Coerce (unsafeCoerce)

#if MIN_VERSION_base(4,19,0)
import GHC.Conc.Sync (fromThreadId)
#else
import GHC.Exts (Addr#, ThreadId#, unsafeCoerce#)
#if __GLASGOW_HASKELL__ >= 904
import Data.Word
#else
import Foreign.C.Types
#endif
#endif

-- | Version of bracket with an INLINE pragma to work around
-- https://gitlab.haskell.org/ghc/ghc/-/issues/22824.
inlineBracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
inlineBracket :: forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
inlineBracket IO a
before a -> IO b
after a -> IO c
action = ((forall a. IO a -> IO a) -> IO c) -> IO c
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO c) -> IO c)
-> ((forall a. IO a -> IO a) -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
  a
a <- IO a
before
  c
r <- IO c -> IO c
forall a. IO a -> IO a
unmask (a -> IO c
action a
a) IO c -> IO b -> IO c
forall a b. IO a -> IO b -> IO a
`onException` a -> IO b
after a
a
  b
_ <- a -> IO b
after a
a
  c -> IO c
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure c
r
{-# INLINE inlineBracket #-}

----------------------------------------

-- | Get an id of a thread that doesn't prevent its garbage collection.
weakThreadId :: ThreadId -> Int
#if MIN_VERSION_base(4,19,0)
weakThreadId :: ThreadId -> Int
weakThreadId = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> (ThreadId -> Word64) -> ThreadId -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> Word64
fromThreadId
#else
weakThreadId (ThreadId t#) = fromIntegral $ rts_getThreadId (threadIdToAddr# t#)

foreign import ccall unsafe "rts_getThreadId"
#if __GLASGOW_HASKELL__ >= 904
  -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6163
  rts_getThreadId :: Addr# -> Word64
#elif __GLASGOW_HASKELL__ >= 900
  -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1254
  rts_getThreadId :: Addr# -> CLong
#else
  rts_getThreadId :: Addr# -> CInt
#endif

-- Note: FFI imports take Addr# instead of ThreadId# because of
-- https://gitlab.haskell.org/ghc/ghc/-/issues/8281, which would prevent loading
-- effectful-core into GHCi.
--
-- Previous workaround was to use an internal library with just this module, but
-- this is not viable because of bugs in stack (sigh).
--
-- The coercion is fine because GHC represents ThreadId# as a pointer.
threadIdToAddr# :: ThreadId# -> Addr#
threadIdToAddr# = unsafeCoerce#
#endif

----------------------------------------

#if __GLASGOW_HASKELL__ < 900

-- | 'Eq' instance for 'ThreadId' is broken in GHC < 9, see
-- https://gitlab.haskell.org/ghc/ghc/-/issues/16761 for more info.
eqThreadId :: ThreadId -> ThreadId -> Bool
eqThreadId (ThreadId t1#) (ThreadId t2#) =
  eq_thread (threadIdToAddr# t1#) (threadIdToAddr# t2#) == 1

foreign import ccall unsafe "effectful_eq_thread"
  eq_thread :: Addr# -> Addr# -> CLong

#else

eqThreadId :: ThreadId -> ThreadId -> Bool
eqThreadId :: ThreadId -> ThreadId -> Bool
eqThreadId = ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
(==)

#endif

----------------------------------------

toAny :: a -> Any
toAny :: forall a. a -> Any
toAny = a -> Any
forall a b. a -> b
unsafeCoerce

fromAny :: Any -> a
fromAny :: forall a. Any -> a
fromAny = Any -> a
forall a b. a -> b
unsafeCoerce

----------------------------------------

-- | A unique with no possibility for CAS contention.
--
-- Credits for this go to Edward Kmett.
newtype Unique = Unique (MutableByteArray RealWorld)

instance Eq Unique where
  Unique MutableByteArray RealWorld
a == :: Unique -> Unique -> Bool
== Unique MutableByteArray RealWorld
b = MutableByteArray RealWorld -> MutableByteArray RealWorld -> Bool
forall s. MutableByteArray s -> MutableByteArray s -> Bool
sameMutableByteArray MutableByteArray RealWorld
a MutableByteArray RealWorld
b

newUnique :: IO Unique
newUnique :: IO Unique
newUnique = MutableByteArray RealWorld -> Unique
Unique (MutableByteArray RealWorld -> Unique)
-> IO (MutableByteArray RealWorld) -> IO Unique
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO (MutableByteArray (PrimState IO))
forall (m :: Type -> Type).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray Int
0

----------------------------------------

thawCallStack :: CallStack -> CallStack
thawCallStack :: CallStack -> CallStack
thawCallStack = \case
  FreezeCallStack CallStack
cs -> CallStack
cs
  CallStack
cs -> CallStack
cs

----------------------------------------

-- | Grow capacity of an array.
--
-- See https://archive.ph/Z2R8w.
growCapacity :: Int -> Int
growCapacity :: Int -> Int
growCapacity Int
n = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Integral a => a -> a -> a
quot (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3) Int
2