diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2016-02-18 Facundo Domínguez 0.3.4.0 + +* Support static pointers. +* Update .travis.yml to drop ghc-7.4 and test ghc-7.10. +* Make Closure and Static strict data types. + 2015-06-15 Facundo Domínguez 0.3.2.0 * Loosen rank1dynamic bounds. diff --git a/distributed-static.cabal b/distributed-static.cabal --- a/distributed-static.cabal +++ b/distributed-static.cabal @@ -1,6 +1,6 @@ Name: distributed-static -Version: 0.3.3.0 -Synopsis: Compositional, type-safe, polymorphic static values and closures +Version: 0.3.4.0 +Synopsis: Compositional, type-safe, polymorphic static values and closures Description: /Towards Haskell in the Cloud/ (Epstein et al, Haskell Symposium 2011) introduces the concept of /static/ values: values that are known at compile time. In a distributed diff --git a/src/Control/Distributed/Static.hs b/src/Control/Distributed/Static.hs --- a/src/Control/Distributed/Static.hs +++ b/src/Control/Distributed/Static.hs @@ -197,11 +197,18 @@ -- > sdictSendPort :: forall a. SerializableDict a -> SerializableDict (SendPort a) -- > sdictSendPort SerializableDict = SerializableDict {-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE StaticPointers #-} +#endif module Control.Distributed.Static ( -- * Static values Static , staticLabel , staticApply +#if __GLASGOW_HASKELL__ >= 710 + , staticPtr + , staticApplyPtr +#endif -- * Derived static combinators , staticCompose , staticSplit @@ -251,20 +258,62 @@ , ANY3 , ANY4 , isInstanceOf +#if __GLASGOW_HASKELL__ >= 710 + , TypeRep +#endif ) +-- Imports necessary to support StaticPtr +#if __GLASGOW_HASKELL__ >= 710 +import qualified GHC.Exts as GHC (Any) +import GHC.StaticPtr +import GHC.Fingerprint.Type (Fingerprint(..)) +import System.IO.Unsafe (unsafePerformIO) +import Data.Rank1Dynamic (unsafeToDynamic) +import Unsafe.Coerce (unsafeCoerce) +#endif + -------------------------------------------------------------------------------- -- Introducing static values -- -------------------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ >= 710 +-- | Static dynamic values +-- +-- In the new proposal for static, the SPT contains these 'TypeRep's. +-- In the current implemnentation however they do not, so we need to carry +-- them ourselves. This is the TypeRep of @a@, /NOT/ of @StaticPtr a@. +data SDynamic = SDynamic TypeRep (StaticPtr GHC.Any) + deriving (Typeable) + +instance Show SDynamic where + show (SDynamic typ ptr) = + "<>" + +instance Eq SDynamic where + SDynamic _ ptr1 == SDynamic _ ptr2 = + staticKey ptr1 == staticKey ptr2 + +instance Ord SDynamic where + SDynamic _ ptr1 `compare` SDynamic _ ptr2 = + staticKey ptr1 `compare` staticKey ptr2 +#endif + data StaticLabel = StaticLabel String | StaticApply !StaticLabel !StaticLabel +#if __GLASGOW_HASKELL__ >= 710 + | StaticPtr SDynamic +#endif deriving (Eq, Ord, Typeable, Show) instance NFData StaticLabel where rnf (StaticLabel s) = rnf s rnf (StaticApply a b) = rnf a `seq` rnf b + -- There are no NFData instances for TypeRep or for StaticPtr :/ +#if __GLASGOW_HASKELL__ >= 710 + rnf (StaticPtr (SDynamic _a _b)) = () +#endif -- | A static value. Static is opaque; see 'staticLabel' and 'staticApply'. newtype Static a = Static StaticLabel @@ -288,6 +337,11 @@ putWord8 0 >> put string putStaticLabel (StaticApply label1 label2) = putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2 +#if __GLASGOW_HASKELL__ >= 710 +putStaticLabel (StaticPtr (SDynamic typ ptr)) = + let Fingerprint hi lo = staticKey ptr + in putWord8 2 >> put typ >> put hi >> put lo +#endif getStaticLabel :: Get StaticLabel getStaticLabel = do @@ -295,8 +349,24 @@ case header of 0 -> StaticLabel <$> get 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel +#if __GLASGOW_HASKELL__ >= 710 + 2 -> do typ <- get + hi <- get + lo <- get + let key = Fingerprint hi lo + case unsaferLookupStaticPtr key of + Nothing -> fail "StaticLabel.get: invalid pointer" + Just ptr -> return $ StaticPtr (SDynamic typ ptr) +#endif _ -> fail "StaticLabel.get: invalid" +#if __GLASGOW_HASKELL__ >= 710 +-- | We need to be able to lookup keys outside of the IO monad so that we +-- can provide a 'Get' instance. +unsaferLookupStaticPtr :: StaticKey -> Maybe (StaticPtr a) +unsaferLookupStaticPtr = unsafePerformIO . unsafeLookupStaticPtr +#endif + -- | Create a primitive static value. -- -- It is the responsibility of the client code to make sure the corresponding @@ -308,6 +378,22 @@ staticApply :: Static (a -> b) -> Static a -> Static b staticApply (Static f) (Static x) = Static (StaticApply f x) +#if __GLASGOW_HASKELL__ >= 710 +-- | Construct a static value from a static pointer +-- +-- Since 0.3.4.0. +staticPtr :: forall a. Typeable a => StaticPtr a -> Static a +staticPtr x = Static . StaticPtr + $ SDynamic (typeOf (undefined :: a)) (unsafeCoerce x) + +-- | Apply a static pointer to a static value +-- +-- Since 0.3.4.0. +staticApplyPtr :: (Typeable a, Typeable b) + => StaticPtr (a -> b) -> Static a -> Static b +staticApplyPtr = staticApply . staticPtr +#endif + -------------------------------------------------------------------------------- -- Eliminating static values -- -------------------------------------------------------------------------------- @@ -341,11 +427,15 @@ f <- resolveStaticLabel rtable label1 x <- resolveStaticLabel rtable label2 f `dynApply` x +#if __GLASGOW_HASKELL__ >= 710 +resolveStaticLabel _ (StaticPtr (SDynamic typ ptr)) = + return $ unsafeToDynamic typ (deRefStaticPtr ptr) +#endif -- | Resolve a static value unstatic :: Typeable a => RemoteTable -> Static a -> Either String a -unstatic rtable (Static static) = do - dyn <- resolveStaticLabel rtable static +unstatic rtable (Static label) = do + dyn <- resolveStaticLabel rtable label fromDynamic dyn -------------------------------------------------------------------------------- @@ -357,7 +447,7 @@ deriving (Eq, Ord, Typeable, Show) instance Typeable a => Binary (Closure a) where - put (Closure static env) = put static >> put env + put (Closure dec env) = put dec >> put env get = Closure <$> get <*> get #if MIN_VERSION_bytestring(0,10,0) @@ -373,13 +463,13 @@ -- | Resolve a closure unclosure :: Typeable a => RemoteTable -> Closure a -> Either String a -unclosure rtable (Closure static env) = do - f <- unstatic rtable static +unclosure rtable (Closure dec env) = do + f <- unstatic rtable dec return (f env) -- | Convert a static value into a closure. staticClosure :: Typeable a => Static a -> Closure a -staticClosure static = closure (staticConst static) empty +staticClosure dec = closure (staticConst dec) empty -------------------------------------------------------------------------------- -- Predefined static values --