diff options
Diffstat (limited to 'libraries')
| -rw-r--r-- | libraries/base/GHC/StaticPtr.hs | 107 | ||||
| -rw-r--r-- | libraries/base/base.cabal | 1 | ||||
| -rw-r--r-- | libraries/template-haskell/Language/Haskell/TH.hs | 2 | ||||
| -rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Lib.hs | 3 | ||||
| -rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Ppr.hs | 2 | ||||
| -rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Syntax.hs | 1 |
6 files changed, 115 insertions, 1 deletions
diff --git a/libraries/base/GHC/StaticPtr.hs b/libraries/base/GHC/StaticPtr.hs new file mode 100644 index 0000000000..e7277ddbb4 --- /dev/null +++ b/libraries/base/GHC/StaticPtr.hs @@ -0,0 +1,107 @@ +----------------------------------------------------------------------------- +-- | +-- 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 indicate +-- package, module and name of a value. This information could be used to locate +-- the value in different processes. +-- +-- Currently, the main use case for references is the StaticPointers language +-- extension. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ExistentialQuantification #-} +module GHC.StaticPtr + ( StaticPtr + , staticName + , StaticName(..) + , DynStaticPtr(..) + , SptEntry + , deRefStaticPtr + , encodeStaticPtr + , decodeStaticPtr + ) where + +import Data.Typeable (Typeable) +import Data.Char +import Foreign.C.String ( withCString, CString ) +import Foreign.Marshal ( withArray ) +import Foreign.Ptr ( castPtr ) +import GHC.Exts ( addrToAny# ) +import GHC.Ptr ( Ptr(..), nullPtr ) +import GHC.Fingerprint ( Fingerprint(..), fingerprintString ) +import Numeric +import System.Info ( os ) +import System.IO.Unsafe ( unsafePerformIO ) +import Unsafe.Coerce ( unsafeCoerce ) + + +-- | A reference to a top-level value of type 'a'. +data StaticPtr a = StaticPtr StaticName a + deriving (Read, Show, Typeable) + +staticName :: StaticPtr a -> StaticName +staticName (StaticPtr n _) = n + +-- | Identification of top-level values +-- +-- > StaticName package_id module_name value_name +-- +data StaticName = StaticName String String String + deriving (Read, Show, Typeable) + +-- | Entries of the static pointer table. +data SptEntry = forall a . SptEntry StaticName a + +-- | Dynamic static pointer. +data DynStaticPtr = forall a . DSP (StaticPtr a) + +-- | Encodes static pointer in the form that can be later serialized. +encodeStaticPtr :: StaticPtr a -> Fingerprint +encodeStaticPtr = fingerprintStaticName . staticName + +-- | Decodes an encoded pointer. It looks up a static pointer in +-- entry in the static pointer table. +decodeStaticPtr :: Fingerprint -> Maybe DynStaticPtr +decodeStaticPtr key = unsafePerformIO $ + fmap (fmap (\(SptEntry s v) -> DSP $ StaticPtr s v)) (sptLookup key) + +-- | Dereferences a static pointer. +deRefStaticPtr :: StaticPtr a -> a +deRefStaticPtr p@(StaticPtr s v) = v + +fingerprintStaticName :: StaticName -> Fingerprint +fingerprintStaticName (StaticName pkg m valsym) = + fingerprintString $ concat [pkg, ":", m, ".", valsym] + +sptLookup :: Fingerprint -> IO (Maybe SptEntry) +sptLookup (Fingerprint w1 w2) = do + ptr@(Ptr addr) <- withArray [w1,w2] (hs_spt_lookup . castPtr) + if (ptr == nullPtr) + then return Nothing + else case addrToAny# addr of + (# spe #) -> return (Just spe) + +foreign import ccall unsafe hs_spt_lookup :: Ptr () -> IO (Ptr a) diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index c3f4d28a1e..b857db4853 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -252,6 +252,7 @@ Library GHC.Ptr GHC.Read GHC.Real + GHC.StaticPtr GHC.ST GHC.STRef GHC.Show diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index e038a3ba6b..ac277b78fa 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -90,7 +90,7 @@ module Language.Haskell.TH( normalB, guardedB, normalG, normalGE, patG, patGE, match, clause, -- *** Expressions - dyn, global, varE, conE, litE, appE, uInfixE, parensE, + dyn, global, varE, conE, litE, appE, uInfixE, parensE, staticE, infixE, infixApp, sectionL, sectionR, lamE, lam1E, lamCaseE, tupE, condE, multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp, diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index efe597275b..97a5a9efe5 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -296,6 +296,9 @@ stringE = litE . stringL fieldExp :: Name -> ExpQ -> Q (Name, Exp) fieldExp s e = do { e' <- e; return (s,e') } +staticE :: ExpQ -> ExpQ +staticE = fmap StaticE + -- ** 'arithSeqE' Shortcuts fromE :: ExpQ -> ExpQ fromE x = do { a <- x; return (ArithSeqE (FromR a)) } diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 5f3a0c6c9b..0f828eb98b 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -172,6 +172,8 @@ pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> text "::" <+> ppr t pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs) pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs) +pprExp i (StaticE e) = parensIf (i >= appPrec) $ + text "static"<+> pprExp appPrec e pprFields :: [(Name,Exp)] -> Doc pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e) diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index ddbe3a98e2..0c75fb99b8 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -1145,6 +1145,7 @@ data Exp | SigE Exp Type -- ^ @{ e :: t }@ | RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@ | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@ + | StaticE Exp -- ^ @{ static e }@ deriving( Show, Eq, Data, Typeable, Generic ) type FieldExp = (Name,Exp) |