{-# LANGUAGE CPP                       #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MagicHash                 #-}
{-# LANGUAGE UnboxedTuples             #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StaticPtr
-- Copyright   :  (C) 2014 I/O Tweag
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- Symbolic references to values.
--
-- References to values are usually implemented with memory addresses, and this
-- is practical when communicating values between the different pieces of a
-- single process.
--
-- When values are communicated across different processes running in possibly
-- different machines, though, addresses are no longer useful since each
-- process may use different addresses to store a given value.
--
-- To solve such concern, the references provided by this module offer a key
-- that can be used to locate the values on each process. Each process maintains
-- a global table of references which can be looked up with a given key. This
-- table is known as the Static Pointer Table. The reference can then be
-- dereferenced to obtain the value.
--
-- The various communicating processes need to aggree on the keys used to refer
-- to the values in the Static Pointer Table, or lookups will fail. Only
-- processes launched from the same program binary are guaranteed to use the
-- same set of keys.
--
-----------------------------------------------------------------------------

module GHC.StaticPtr
  ( StaticPtr
  , deRefStaticPtr
  , StaticKey
  , staticKey
  , unsafeLookupStaticPtr
  , StaticPtrInfo(..)
  , staticPtrInfo
  , staticPtrKeys
  , IsStatic(..)
  ) where

import Foreign.C.Types     (CInt(..))
import Foreign.Marshal     (allocaArray, peekArray, withArray)
import GHC.Ptr             (Ptr(..), nullPtr)
import GHC.Fingerprint     (Fingerprint(..))
import GHC.Prim
import GHC.Word            (Word64(..))


#include "MachDeps.h"

-- | A reference to a value of type @a@.
#if WORD_SIZE_IN_BITS < 64
data StaticPtr a = StaticPtr Word64# Word64# -- The flattened Fingerprint is
                                             -- convenient in the compiler.
                             StaticPtrInfo a
#else
data StaticPtr a = StaticPtr Word# Word#
                             StaticPtrInfo a
#endif
-- | Dereferences a static pointer.
deRefStaticPtr :: StaticPtr a -> a
deRefStaticPtr :: forall a. StaticPtr a -> a
deRefStaticPtr (StaticPtr Word#
_ Word#
_ StaticPtrInfo
_ a
v) = a
v

-- | A key for 'StaticPtr's that can be serialized and used with
-- 'unsafeLookupStaticPtr'.
type StaticKey = Fingerprint

-- | The 'StaticKey' that can be used to look up the given 'StaticPtr'.
staticKey :: StaticPtr a -> StaticKey
staticKey :: forall a. StaticPtr a -> StaticKey
staticKey (StaticPtr Word#
w0 Word#
w1 StaticPtrInfo
_ a
_) = Word64 -> Word64 -> StaticKey
Fingerprint (Word# -> Word64
W64# Word#
w0) (Word# -> Word64
W64# Word#
w1)

-- | Looks up a 'StaticPtr' by its 'StaticKey'.
--
-- If the 'StaticPtr' is not found returns @Nothing@.
--
-- This function is unsafe because the program behavior is undefined if the type
-- of the returned 'StaticPtr' does not match the expected one.
--
unsafeLookupStaticPtr :: StaticKey -> IO (Maybe (StaticPtr a))
unsafeLookupStaticPtr :: forall a. StaticKey -> IO (Maybe (StaticPtr a))
unsafeLookupStaticPtr (Fingerprint Word64
w1 Word64
w2) = do
    ptr :: Ptr Any
ptr@(Ptr Addr#
addr) <- forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [Word64
w1, Word64
w2] forall a. Ptr Word64 -> IO (Ptr a)
hs_spt_lookup
    if (Ptr Any
ptr forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr)
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    else case forall a. Addr# -> (# a #)
addrToAny# Addr#
addr of
           (# StaticPtr a
spe #) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just StaticPtr a
spe)

foreign import ccall unsafe hs_spt_lookup :: Ptr Word64 -> IO (Ptr a)

-- | A class for things buildable from static pointers.
class IsStatic p where
    fromStaticPtr :: StaticPtr a -> p a

-- | @since 4.9.0.0
instance IsStatic StaticPtr where
    fromStaticPtr :: forall a. StaticPtr a -> StaticPtr a
fromStaticPtr = forall a. a -> a
id

-- | Miscellaneous information available for debugging purposes.
data StaticPtrInfo = StaticPtrInfo
    { -- | Package key of the package where the static pointer is defined
      StaticPtrInfo -> String
spInfoUnitId  :: String
      -- | Name of the module where the static pointer is defined
    , StaticPtrInfo -> String
spInfoModuleName :: String
      -- | Source location of the definition of the static pointer as a
      -- @(Line, Column)@ pair.
    , StaticPtrInfo -> (Int, Int)
spInfoSrcLoc     :: (Int, Int)
    }
  deriving Int -> StaticPtrInfo -> ShowS
[StaticPtrInfo] -> ShowS
StaticPtrInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StaticPtrInfo] -> ShowS
$cshowList :: [StaticPtrInfo] -> ShowS
show :: StaticPtrInfo -> String
$cshow :: StaticPtrInfo -> String
showsPrec :: Int -> StaticPtrInfo -> ShowS
$cshowsPrec :: Int -> StaticPtrInfo -> ShowS
Show -- ^ @since 4.8.0.0

-- | 'StaticPtrInfo' of the given 'StaticPtr'.
staticPtrInfo :: StaticPtr a -> StaticPtrInfo
staticPtrInfo :: forall a. StaticPtr a -> StaticPtrInfo
staticPtrInfo (StaticPtr Word#
_ Word#
_ StaticPtrInfo
n a
_) = StaticPtrInfo
n

-- | A list of all known keys.
staticPtrKeys :: IO [StaticKey]
staticPtrKeys :: IO [StaticKey]
staticPtrKeys = do
    CInt
keyCount <- IO CInt
hs_spt_key_count
    forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
keyCount) forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr Word64)
p -> do
      CInt
count <- forall a. Ptr a -> CInt -> IO CInt
hs_spt_keys Ptr (Ptr Word64)
p CInt
keyCount
      forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
count) Ptr (Ptr Word64)
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Ptr Word64
pa -> forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
2 Ptr Word64
pa forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Word64
w1, Word64
w2] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> StaticKey
Fingerprint Word64
w1 Word64
w2)
{-# NOINLINE staticPtrKeys #-}

foreign import ccall unsafe hs_spt_key_count :: IO CInt

foreign import ccall unsafe hs_spt_keys :: Ptr a -> CInt -> IO CInt