Implement -XStaticValues
authorFacundo Domínguez <facundo.dominguez@tweag.io>
Wed, 10 Dec 2014 00:10:18 +0000 (18:10 -0600)
committerAustin Seipp <austin@well-typed.com>
Wed, 10 Dec 2014 01:59:27 +0000 (19:59 -0600)
Summary:
As proposed in [1], this extension introduces a new syntactic form
`static e`, where `e :: a` can be any closed expression. The static form
produces a value of type `StaticPtr a`, which works as a reference that
programs can "dereference" to get the value of `e` back. References are
like `Ptr`s, except that they are stable across invocations of a
program.

The relevant wiki pages are [2, 3], which describe the motivation/ideas
and implementation plan respectively.

[1] Jeff Epstein, Andrew P. Black, and Simon Peyton-Jones. Towards
Haskell in the cloud. SIGPLAN Not., 46(12):118–129, September 2011. ISSN
0362-1340.
[2] https://ghc.haskell.org/trac/ghc/wiki/StaticPointers
[3] https://ghc.haskell.org/trac/ghc/wiki/StaticPointers/ImplementationPlan

Authored-by: Facundo Domínguez <facundo.dominguez@tweag.io>
Authored-by: Mathieu Boespflug <m@tweag.io>
Authored-by: Alexander Vershilov <alexander.vershilov@tweag.io>
Test Plan: `./validate`

Reviewers: hvr, simonmar, simonpj, austin

Reviewed By: simonpj, austin

Subscribers: qnikst, bgamari, mboes, carter, thomie, goldfire

Differential Revision: https://phabricator.haskell.org/D550

GHC Trac Issues: #7015

71 files changed:
compiler/deSugar/Coverage.hs
compiler/deSugar/Desugar.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsMonad.hs
compiler/deSugar/StaticPtrTable.hs [new file with mode: 0644]
compiler/ghc.cabal.in
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsExpr.hs
compiler/main/DynFlags.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y
compiler/prelude/PrelNames.hs
compiler/rename/RnExpr.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
docs/users_guide/glasgow_exts.xml
includes/HsFFI.h
includes/Rts.h
includes/rts/StaticPtrTable.h [new file with mode: 0644]
libraries/base/GHC/StaticPtr.hs [new file with mode: 0644]
libraries/base/base.cabal
libraries/template-haskell/Language/Haskell/TH.hs
libraries/template-haskell/Language/Haskell/TH/Lib.hs
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
rts/Hash.c
rts/Hash.h
rts/Linker.c
rts/RtsStartup.c
rts/StaticPtrTable.c [new file with mode: 0644]
rts/StaticPtrTable.h [new file with mode: 0644]
testsuite/tests/codeGen/should_run/CgStaticPointers.hs [new file with mode: 0644]
testsuite/tests/codeGen/should_run/CgStaticPointers.stdout [new file with mode: 0644]
testsuite/tests/codeGen/should_run/all.T
testsuite/tests/deSugar/should_run/DsStaticPointers.hs [new file with mode: 0644]
testsuite/tests/deSugar/should_run/DsStaticPointers.stdout [new file with mode: 0644]
testsuite/tests/deSugar/should_run/all.T
testsuite/tests/driver/T4437.hs
testsuite/tests/parser/should_compile/RdrNoStaticPointers01.hs [new file with mode: 0644]
testsuite/tests/parser/should_compile/all.T
testsuite/tests/rename/should_fail/RnStaticPointersFail01.hs [new file with mode: 0644]
testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr [new file with mode: 0644]
testsuite/tests/rename/should_fail/RnStaticPointersFail02.hs [new file with mode: 0644]
testsuite/tests/rename/should_fail/RnStaticPointersFail02.stderr [new file with mode: 0644]
testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs [new file with mode: 0644]
testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr [new file with mode: 0644]
testsuite/tests/rename/should_fail/all.T
testsuite/tests/rts/GcStaticPointers.hs [new file with mode: 0644]
testsuite/tests/rts/GcStaticPointers.stdout [new file with mode: 0644]
testsuite/tests/rts/ListStaticPointers.hs [new file with mode: 0644]
testsuite/tests/rts/all.T
testsuite/tests/th/TH_StaticPointers.hs [new file with mode: 0644]
testsuite/tests/th/TH_StaticPointers.stdout [new file with mode: 0644]
testsuite/tests/th/TH_StaticPointers02.hs [new file with mode: 0644]
testsuite/tests/th/TH_StaticPointers02.stderr [new file with mode: 0644]
testsuite/tests/th/all.T
testsuite/tests/typecheck/should_compile/TcStaticPointers01.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/TcStaticPointers02.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T
testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/all.T

index 8ae8933..f57cc9e 100644 (file)
@@ -533,6 +533,9 @@ addTickHsExpr (ExplicitPArr ty es) =
         liftM2 ExplicitPArr
                 (return ty)
                 (mapM (addTickLHsExpr) es)
+
+addTickHsExpr (HsStatic e) = HsStatic <$> addTickLHsExpr e
+
 addTickHsExpr (RecordCon id ty rec_binds) =
         liftM3 RecordCon
                 (return id)
index ac4bdb2..d6ccdaf 100644 (file)
@@ -49,6 +49,7 @@ import Coverage
 import Util
 import MonadUtils
 import OrdList
+import StaticPtrTable
 import Data.List
 import Data.IORef
 import Control.Monad( when )
@@ -91,7 +92,7 @@ deSugar hsc_env
                             tcg_tcs          = tcs,
                             tcg_insts        = insts,
                             tcg_fam_insts    = fam_insts,
-                            tcg_hpc          = other_hpc_info })
+                            tcg_hpc          = other_hpc_info})
 
   = do { let dflags = hsc_dflags hsc_env
              print_unqual = mkPrintUnqualified dflags rdr_env
@@ -121,13 +122,20 @@ deSugar hsc_env
                           ; (ds_fords, foreign_prs) <- dsForeigns fords
                           ; ds_rules <- mapMaybeM dsRule rules
                           ; ds_vects <- mapM dsVect vects
+                          ; stBinds <- dsGetStaticBindsVar >>=
+                                           liftIO . readIORef
                           ; let hpc_init
                                   | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
                                   | otherwise = empty
+                                -- Stub to insert the static entries of the
+                                -- module into the static pointer table
+                                spt_init = sptInitCode mod stBinds
                           ; return ( ds_ev_binds
                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
+                                                 `appOL` toOL (map snd stBinds)
                                    , spec_rules ++ ds_rules, ds_vects
-                                   , ds_fords `appendStubC` hpc_init) }
+                                   , ds_fords `appendStubC` hpc_init
+                                              `appendStubC` spt_init) }
 
         ; case mb_res of {
            Nothing -> return (msgs, Nothing) ;
index e94936d..d252d91 100644 (file)
@@ -31,6 +31,7 @@ import DsMeta
 
 import HsSyn
 
+import Platform
 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
 --     needs to see source types
 import TcType
@@ -52,6 +53,7 @@ import VarEnv
 import ConLike
 import DataCon
 import TysWiredIn
+import PrelNames
 import BasicTypes
 import Maybes
 import SrcLoc
@@ -60,7 +62,11 @@ import Bag
 import Outputable
 import FastString
 
+import IdInfo
+import Data.IORef       ( atomicModifyIORef, modifyIORef )
+
 import Control.Monad
+import GHC.Fingerprint
 
 {-
 ************************************************************************
@@ -391,6 +397,78 @@ dsExpr (PArrSeq _ _)
 
 {-
 \noindent
+\underline{\bf Static Pointers}
+               ~~~~~~~~~~~~~~~
+\begin{verbatim}
+    g = ... static f ...
+==>
+    sptEntry:N = StaticPtr
+        (fingerprintString "pkgId:module.sptEntry:N")
+        (StaticPtrInfo "current pkg id" "current module" "sptEntry:0")
+        f
+    g = ... sptEntry:N
+\end{verbatim}
+-}
+
+dsExpr (HsStatic expr@(L loc _)) = do
+    expr_ds <- dsLExpr expr
+    let ty = exprType expr_ds
+    n' <- mkSptEntryName loc
+    static_binds_var <- dsGetStaticBindsVar
+
+    staticPtrTyCon       <- dsLookupTyCon   staticPtrTyConName
+    staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName
+    staticPtrDataCon     <- dsLookupDataCon staticPtrDataConName
+    fingerprintDataCon   <- dsLookupDataCon fingerprintDataConName
+
+    dflags <- getDynFlags
+    let (line, col) = case loc of
+           RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r
+                            , srcLocCol  $ realSrcSpanStart r
+                            )
+           _             -> (0, 0)
+        srcLoc = mkCoreConApps (tupleCon BoxedTuple 2)
+                     [ Type intTy              , Type intTy
+                     , mkIntExprInt dflags line, mkIntExprInt dflags col
+                     ]
+    info <- mkConApp staticPtrInfoDataCon <$>
+            (++[srcLoc]) <$>
+            mapM mkStringExprFS
+                 [ packageKeyFS $ modulePackageKey $ nameModule n'
+                 , moduleNameFS $ moduleName $ nameModule n'
+                 , occNameFS    $ nameOccName n'
+                 ]
+    let tvars = varSetElems $ tyVarsOfType ty
+        speTy = mkForAllTys tvars $ mkTyConApp staticPtrTyCon [ty]
+        speId = mkExportedLocalId VanillaId n' speTy
+        fp@(Fingerprint w0 w1) = fingerprintName $ idName speId
+        fp_core = mkConApp fingerprintDataCon
+                    [ mkWord64LitWordRep dflags w0
+                    , mkWord64LitWordRep dflags w1
+                    ]
+        sp    = mkConApp staticPtrDataCon [Type ty, fp_core, info, expr_ds]
+    liftIO $ modifyIORef static_binds_var ((fp, (speId, mkLams tvars sp)) :)
+    putSrcSpanDs loc $ return $ mkTyApps (Var speId) (map mkTyVarTy tvars)
+
+  where
+
+    -- | Choose either 'Word64#' or 'Word#' to represent the arguments of the
+    -- 'Fingerprint' data constructor.
+    mkWord64LitWordRep dflags
+      | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64
+      | otherwise = mkWordLit dflags . toInteger
+
+    fingerprintName :: Name -> Fingerprint
+    fingerprintName n = fingerprintString $ unpackFS $ concatFS
+        [ packageKeyFS $ modulePackageKey $ nameModule n
+        , fsLit ":"
+        , moduleNameFS (moduleName $ nameModule n)
+        , fsLit "."
+        , occNameFS $ occName n
+        ]
+
+{-
+\noindent
 \underline{\bf Record construction and update}
              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 For record construction we do this (assuming T has three arguments)
@@ -857,3 +935,34 @@ badMonadBind rhs elt_ty flag_doc
          , hang (ptext (sLit "Suppress this warning by saying"))
               2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs)
          , ptext (sLit "or by using the flag") <+>  flag_doc ]
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Static pointers}
+*                                                                      *
+************************************************************************
+-}
+
+-- | Creates an name for an entry in the Static Pointer Table.
+--
+-- The name has the form @sptEntry:<N>@ where @<N>@ is generated from a
+-- per-module counter.
+--
+mkSptEntryName :: SrcSpan -> DsM Name
+mkSptEntryName loc = do
+    uniq <- newUnique
+    mod  <- getModule
+    occ  <- mkWrapperName "sptEntry"
+    return $ mkExternalName uniq mod occ loc
+  where
+    mkWrapperName what
+      = do dflags <- getDynFlags
+           thisMod <- getModule
+           let -- Note [Generating fresh names for ccall wrapper]
+               -- in compiler/typecheck/TcEnv.hs
+               wrapperRef = nextWrapperNum dflags
+           wrapperNum <- liftIO $ atomicModifyIORef wrapperRef $ \mod_env ->
+               let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
+                in (extendModuleEnv mod_env thisMod (num+1), num)
+           return $ mkVarOcc $ what ++ ":" ++ show wrapperNum
index 2addbdf..b236f9c 100644 (file)
@@ -1092,6 +1092,7 @@ repE (ArithSeq _ _ aseq) =
                              repFromThenTo ds1 ds2 ds3
 
 repE (HsSpliceE _ splice)  = repSplice splice
+repE (HsStatic e)          = repLE e >>= rep2 staticEName . (:[]) . unC
 repE e@(PArrSeq {})        = notHandled "Parallel arrays" (ppr e)
 repE e@(HsCoreAnn {})      = notHandled "Core annotations" (ppr e)
 repE e@(HsSCC {})          = notHandled "Cost centres" (ppr e)
@@ -2125,7 +2126,7 @@ templateHaskellNames = [
     tupEName, unboxedTupEName,
     condEName, multiIfEName, letEName, caseEName, doEName, compEName,
     fromEName, fromThenEName, fromToEName, fromThenToEName,
-    listEName, sigEName, recConEName, recUpdEName,
+    listEName, sigEName, recConEName, recUpdEName, staticEName,
     -- FieldExp
     fieldExpName,
     -- Body
@@ -2307,7 +2308,7 @@ clauseName = libFun (fsLit "clause") clauseIdKey
 varEName, conEName, litEName, appEName, infixEName, infixAppName,
     sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
     unboxedTupEName, condEName, multiIfEName, letEName, caseEName,
-    doEName, compEName :: Name
+    doEName, compEName, staticEName :: Name
 varEName        = libFun (fsLit "varE")        varEIdKey
 conEName        = libFun (fsLit "conE")        conEIdKey
 litEName        = libFun (fsLit "litE")        litEIdKey
@@ -2338,6 +2339,7 @@ listEName       = libFun (fsLit "listE")       listEIdKey
 sigEName        = libFun (fsLit "sigE")        sigEIdKey
 recConEName     = libFun (fsLit "recConE")     recConEIdKey
 recUpdEName     = libFun (fsLit "recUpdE")     recUpdEIdKey
+staticEName     = libFun (fsLit "staticE")     staticEIdKey
 
 -- type FieldExp = ...
 fieldExpName :: Name
@@ -2680,7 +2682,7 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
     unboxedTupEIdKey, condEIdKey, multiIfEIdKey,
     letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
-    listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
+    listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey :: Unique
 varEIdKey         = mkPreludeMiscIdUnique 270
 conEIdKey         = mkPreludeMiscIdUnique 271
 litEIdKey         = mkPreludeMiscIdUnique 272
@@ -2707,6 +2709,7 @@ listEIdKey        = mkPreludeMiscIdUnique 292
 sigEIdKey         = mkPreludeMiscIdUnique 293
 recConEIdKey      = mkPreludeMiscIdUnique 294
 recUpdEIdKey      = mkPreludeMiscIdUnique 295
+staticEIdKey      = mkPreludeMiscIdUnique 296
 
 -- type FieldExp = ...
 fieldExpIdKey :: Unique
index 9c987a2..7c56199 100644 (file)
@@ -21,7 +21,7 @@ module DsMonad (
         mkPrintUnqualifiedDs,
         newUnique,
         UniqSupply, newUniqueSupply,
-        getGhcModeDs, dsGetFamInstEnvs,
+        getGhcModeDs, dsGetFamInstEnvs, dsGetStaticBindsVar,
         dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
 
         PArrBuiltin(..),
@@ -67,6 +67,7 @@ import Maybes
 
 import Data.IORef
 import Control.Monad
+import GHC.Fingerprint
 
 {-
 ************************************************************************
@@ -166,6 +167,8 @@ data DsGblEnv
                                                 -- exported entities of 'Data.Array.Parallel' iff
                                                 -- '-XParallelArrays' was given; otherwise, empty
         , ds_parr_bi :: PArrBuiltin             -- desugarar names for '-XParallelArrays'
+        , ds_static_binds :: IORef [(Fingerprint, (Id,CoreExpr))]
+          -- ^ Bindings resulted from floating static forms
         }
 
 instance ContainsModule DsGblEnv where
@@ -196,8 +199,11 @@ initDs :: HscEnv
 
 initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
   = do  { msg_var <- newIORef (emptyBag, emptyBag)
+        ; static_binds_var <- newIORef []
         ; let dflags                   = hsc_dflags hsc_env
-              (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var
+              (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env
+                                                  fam_inst_env msg_var
+                                                  static_binds_var
 
         ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
                           loadDAP $
@@ -272,15 +278,19 @@ initDsTc thing_inside
         ; tcg_env  <- getGblEnv
         ; msg_var  <- getErrsVar
         ; dflags   <- getDynFlags
+        ; static_binds_var <- liftIO $ newIORef []
         ; let type_env = tcg_type_env tcg_env
               rdr_env  = tcg_rdr_env tcg_env
               fam_inst_env = tcg_fam_inst_env tcg_env
-              ds_envs  = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env msg_var
+              ds_envs  = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
+                                  msg_var static_binds_var
         ; setEnvs ds_envs thing_inside
         }
 
-mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> IORef Messages -> (DsGblEnv, DsLclEnv)
-mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var
+mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+         -> IORef Messages -> IORef [(Fingerprint, (Id, CoreExpr))]
+         -> (DsGblEnv, DsLclEnv)
+mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var
   = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
         if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
         gbl_env = DsGblEnv { ds_mod     = mod
@@ -290,6 +300,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var
                            , ds_msgs    = msg_var
                            , ds_dph_env = emptyGlobalRdrEnv
                            , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
+                           , ds_static_binds = static_binds_var
                            }
         lcl_env = DsLclEnv { ds_meta = emptyNameEnv
                            , ds_loc  = noSrcSpan
@@ -487,6 +498,10 @@ dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 dsExtendMetaEnv menv thing_inside
   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
 
+-- | Gets a reference to the SPT entries created so far.
+dsGetStaticBindsVar :: DsM (IORef [(Fingerprint, (Id,CoreExpr))])
+dsGetStaticBindsVar = fmap ds_static_binds getGblEnv
+
 discardWarningsDs :: DsM a -> DsM a
 -- Ignore warnings inside the thing inside;
 -- used to ignore inaccessable cases etc. inside generated code
diff --git a/compiler/deSugar/StaticPtrTable.hs b/compiler/deSugar/StaticPtrTable.hs
new file mode 100644 (file)
index 0000000..d4cad0e
--- /dev/null
@@ -0,0 +1,75 @@
+-- | Code generation for the Static Pointer Table
+--
+-- (c) 2014 I/O Tweag
+--
+-- Each module that uses 'static' keyword declares an initialization function of
+-- the form hs_spt_init_<module>() which is emitted into the _stub.c file and
+-- annotated with __attribute__((constructor)) so that it gets executed at
+-- startup time.
+--
+-- The function's purpose is to call hs_spt_insert to insert the static
+-- pointers of this module in the hashtable of the RTS, and it looks something
+-- like this:
+--
+-- > static void hs_hpc_init_Main(void) __attribute__((constructor));
+-- > static void hs_hpc_init_Main(void) {
+-- >
+-- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
+-- >   extern StgPtr Main_sptEntryZC0_closure;
+-- >   hs_spt_insert(k0, &Main_sptEntryZC0_closure);
+-- >
+-- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
+-- >   extern StgPtr Main_sptEntryZC1_closure;
+-- >   hs_spt_insert(k1, &Main_sptEntryZC1_closure);
+-- >
+-- > }
+--
+-- where constants are values of a fingerprint of the string
+-- "<package_id>:<module_name>.sptEntry:<N>"
+--
+module StaticPtrTable (sptInitCode) where
+
+import CoreSyn
+import Module
+import Outputable
+import Id
+import CLabel
+import GHC.Fingerprint
+
+
+-- | @sptInitCode module statics@ is a C stub to insert the static entries
+-- @statics@ of @module@ into the static pointer table
+--
+-- Each entry contains the fingerprint used to locate the entry and the
+-- top-level binding for the entry.
+--
+sptInitCode :: Module -> [(Fingerprint, (Id,CoreExpr))] -> SDoc
+sptInitCode _ [] = Outputable.empty
+sptInitCode this_mod entries = vcat
+    [ text "static void hs_spt_init_" <> ppr this_mod
+           <> text "(void) __attribute__((constructor));"
+    , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"
+    , braces $ vcat $
+        [  text "static StgWord64 k" <> int i <> text "[2] = "
+           <> pprFingerprint fp <> semi
+        $$ text "extern StgPtr "
+           <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
+        $$ text "hs_spt_insert" <> parens
+             (hcat $ punctuate comma
+                [ char 'k' <> int i
+                , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n))
+                ]
+             )
+        <> semi
+        |  (i, (fp, (n, _))) <- zip [0..] entries
+        ]
+    ]
+
+  where
+
+    pprFingerprint :: Fingerprint -> SDoc
+    pprFingerprint (Fingerprint w1 w2) =
+      braces $ hcat $ punctuate comma
+                 [ integer (fromIntegral w1) <> text "ULL"
+                 , integer (fromIntegral w2) <> text "ULL"
+                 ]
index 5c9f17a..21aa732 100644 (file)
@@ -323,6 +323,7 @@ Library
         TcPluginM
         PprTyThing
         StaticFlags
+        StaticPtrTable
         SysTools
         TidyPgm
         Ctype
index 8dc60d6..e612097 100644 (file)
@@ -688,6 +688,7 @@ cvtl e = wrapL (cvt e)
     cvt (RecUpdE e flds) = do { e' <- cvtl e
                               ; flds' <- mapM cvtFld flds
                               ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
+    cvt (StaticE e)      = fmap HsStatic $ cvtl e
 
 {- Note [Dropping constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 1861811..384222b 100644 (file)
@@ -348,6 +348,10 @@ data HsExpr id
                                         -- always has an empty stack
 
   ---------------------------------------
+  -- static pointers extension
+  | HsStatic    (LHsExpr id)
+
+  ---------------------------------------
   -- The following are commands, not expressions proper
   -- They are only used in the parsing stage and are removed
   --    immediately in parser.RdrHsSyn.checkCommand
@@ -656,6 +660,9 @@ ppr_expr (HsQuasiQuoteE qq)    = ppr qq
 ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
   = hsep [ptext (sLit "proc"), ppr pat, ptext (sLit "->"), ppr cmd]
 
+ppr_expr (HsStatic e)
+  = hsep [ptext (sLit "static"), pprParendExpr e]
+
 ppr_expr (HsTick tickish exp)
   = pprTicks (ppr exp) $
     ppr tickish <+> ppr exp
index 64a81fc..d6b75af 100644 (file)
@@ -625,6 +625,7 @@ data ExtensionFlag
    | Opt_PatternSynonyms
    | Opt_PartialTypeSignatures
    | Opt_NamedWildcards
+   | Opt_StaticPointers
    deriving (Eq, Enum, Show)
 
 data SigOf = NotSigOf
@@ -3124,6 +3125,7 @@ xFlags = [
   flagSpec "RoleAnnotations"                  Opt_RoleAnnotations,
   flagSpec "ScopedTypeVariables"              Opt_ScopedTypeVariables,
   flagSpec "StandaloneDeriving"               Opt_StandaloneDeriving,
+  flagSpec "StaticPointers"                   Opt_StaticPointers,
   flagSpec' "TemplateHaskell"                 Opt_TemplateHaskell
                                               checkTemplateHaskellOk,
   flagSpec "TraditionalRecordSyntax"          Opt_TraditionalRecordSyntax,
index d7ee0b6..596f3bd 100644 (file)
@@ -558,6 +558,7 @@ data Token
   | ITby
   | ITusing
   | ITpattern
+  | ITstatic
 
   -- Pragmas
   | ITinline_prag InlineSpec RuleMatchInfo
@@ -744,6 +745,7 @@ reservedWordsFM = listToUFM $
          ( "family",         ITfamily,        0 ),
          ( "role",           ITrole,          0 ),
          ( "pattern",        ITpattern,       xbit PatternSynonymsBit),
+         ( "static",         ITstatic,        0 ),
          ( "group",          ITgroup,         xbit TransformComprehensionsBit),
          ( "by",             ITby,            xbit TransformComprehensionsBit),
          ( "using",          ITusing,         xbit TransformComprehensionsBit),
@@ -1117,6 +1119,11 @@ varid span buf len =
                    return ITcase
       maybe_layout keyword
       return $ L span keyword
+    Just (ITstatic, _) -> do
+      flags <- getDynFlags
+      if xopt Opt_StaticPointers flags
+        then return $ L span ITstatic
+        else return $ L span $ ITvarid fs
     Just (keyword, 0) -> do
       maybe_layout keyword
       return $ L span keyword
index c7143ae..ed111c0 100644 (file)
@@ -302,6 +302,7 @@ See https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations for some background.
  'by'       { L _ ITby }        -- for list transform extension
  'using'    { L _ ITusing }     -- for list transform extension
  'pattern'      { L _ ITpattern } -- for pattern synonyms
+ 'static'       { L _ ITstatic }  -- for static pointers extension
 
  '{-# INLINE'             { L _ (ITinline_prag _ _) }
  '{-# SPECIALISE'         { L _ ITspec_prag }
@@ -2031,6 +2032,7 @@ hpc_annot :: { Located ([AddAnn],(FastString,(Int,Int),(Int,Int))) }
 
 fexp    :: { LHsExpr RdrName }
         : fexp aexp                             { sLL $1 $> $ HsApp $1 $2 }
+        | 'static' aexp                         { sLL $1 $> $ HsStatic $2 }
         | aexp                                  { $1 }
 
 aexp    :: { LHsExpr RdrName }
index 65eaebb..0964dd4 100644 (file)
@@ -349,6 +349,14 @@ basicKnownKeyNames
 
         -- GHCi Sandbox
         , ghciIoClassName, ghciStepIoMName
+
+        -- StaticPtr
+        , staticPtrTyConName
+        , staticPtrDataConName, staticPtrInfoDataConName
+
+        -- Fingerprint
+        , fingerprintDataConName
+
     ] ++ case cIntegerLibraryType of
            IntegerGMP    -> [integerSDataConName]
            IntegerGMP2   -> [integerSDataConName]
@@ -447,6 +455,12 @@ gHC_IP          = mkBaseModule (fsLit "GHC.IP")
 gHC_PARR' :: Module
 gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
 
+gHC_STATICPTR :: Module
+gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")
+
+gHC_FINGERPRINT_TYPE :: Module
+gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type")
+
 mAIN, rOOT_MAIN :: Module
 mAIN            = mkMainModule_ mAIN_NAME
 rOOT_MAIN       = mkMainModule (fsLit ":Main") -- Root module for initialisation
@@ -1159,6 +1173,27 @@ pLUGINS = mkThisGhcModule (fsLit "Plugins")
 pluginTyConName :: Name
 pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey
 
+-- Static pointers
+staticPtrInfoTyConName :: Name
+staticPtrInfoTyConName =
+    tcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey
+
+staticPtrInfoDataConName :: Name
+staticPtrInfoDataConName =
+    conName gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey
+
+staticPtrTyConName :: Name
+staticPtrTyConName =
+    tcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey
+
+staticPtrDataConName :: Name
+staticPtrDataConName =
+    conName gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey
+
+fingerprintDataConName :: Name
+fingerprintDataConName =
+    conName gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1476,6 +1511,12 @@ specTyConKey = mkPreludeTyConUnique 177
 smallArrayPrimTyConKey        = mkPreludeTyConUnique  178
 smallMutableArrayPrimTyConKey = mkPreludeTyConUnique  179
 
+staticPtrTyConKey  :: Unique
+staticPtrTyConKey  = mkPreludeTyConUnique 180
+
+staticPtrInfoTyConKey :: Unique
+staticPtrInfoTyConKey = mkPreludeTyConUnique 181
+
 ---------------- Template Haskell -------------------
 --      USES TyConUniques 200-299
 -----------------------------------------------------
@@ -1539,6 +1580,15 @@ gtDataConKey                            = mkPreludeDataConUnique 29
 
 coercibleDataConKey                     = mkPreludeDataConUnique 32
 
+staticPtrDataConKey :: Unique
+staticPtrDataConKey                     = mkPreludeDataConUnique 33
+
+staticPtrInfoDataConKey :: Unique
+staticPtrInfoDataConKey                 = mkPreludeDataConUnique 34
+
+fingerprintDataConKey :: Unique
+fingerprintDataConKey                   = mkPreludeDataConUnique 35
+
 {-
 ************************************************************************
 *                                                                      *
index a0b5a15..4755547 100644 (file)
@@ -307,6 +307,43 @@ rnExpr e@(ELazyPat {}) = patSynErr e
 {-
 ************************************************************************
 *                                                                      *
+        Static values
+*                                                                      *
+************************************************************************
+
+For the static form we check that the free variables are all top-level
+value bindings. This is done by checking that the name is external or
+wired-in. See the Note about the NameSorts in Name.lhs.
+-}
+
+rnExpr e@(HsStatic expr) = do
+    (expr',fvExpr) <- rnLExpr expr
+    stage <- getStage
+    case stage of
+      Brack _ _ -> return () -- Don't check names if we are inside brackets.
+                             -- We don't want to reject cases like:
+                             -- \e -> [| static $(e) |]
+                             -- if $(e) turns out to produce a legal expression.
+      Splice _ -> addErr $ sep
+             [ text "static forms cannot be used in splices:"
+             , nest 2 $ ppr e
+             ]
+      _ -> do
+       let isTopLevelName n = isExternalName n || isWiredInName n
+       case nameSetElems $ filterNameSet (not . isTopLevelName) fvExpr of
+         [] -> return ()
+         fvNonGlobal -> addErr $ cat
+             [ text $ "Only identifiers of top-level bindings can "
+                      ++ "appear in the body of the static form:"
+             , nest 2 $ ppr e
+             , text "but the following identifiers were found instead:"
+             , nest 2 $ vcat $ map ppr fvNonGlobal
+             ]
+    return (HsStatic expr', fvExpr)
+
+{-
+************************************************************************
+*                                                                      *
         Arrow notation
 *                                                                      *
 ************************************************************************
index 79f630e..a0bc89e 100644 (file)
@@ -12,7 +12,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
                  PragFun, tcSpecPrags, tcVectDecls, mkPragFun,
                  TcSigInfo(..), TcSigFun,
                  instTcTySig, instTcTySigFromId, findScopedTyVars,
-                 badBootDeclErr ) where
+                 badBootDeclErr, mkExport ) where
 
 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
 import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
index 9503d2b..9a60ffb 100644 (file)
@@ -487,6 +487,28 @@ tcExpr (HsProc pat cmd) res_ty
   = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
         ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
 
+tcExpr (HsStatic expr) res_ty
+  = do  { staticPtrTyCon  <- tcLookupTyCon staticPtrTyConName
+        ; (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty
+        ; (expr', lie)    <- captureConstraints $
+            addErrCtxt (hang (ptext (sLit "In the body of a static form:"))
+                             2 (ppr expr)
+                       ) $
+            tcPolyExprNC expr expr_ty
+        -- Require the type of the argument to be Typeable.
+        -- The evidence is not used, but asking the constraint ensures that
+        -- the current implementation is as restrictive as future versions
+        -- of the StaticPointers extension.
+        ; typeableClass <- tcLookupClass typeableClassName
+        ; _ <- emitWanted StaticOrigin $
+                  mkTyConApp (classTyCon typeableClass)
+                             [liftedTypeKind, expr_ty]
+        -- Insert the static form in a global list for later validation.
+        ; stWC <- tcg_static_wc <$> getGblEnv
+        ; updTcRef stWC (andWC lie)
+        ; return $ mkHsWrapCo co $ HsStatic expr'
+        }
+
 {-
 Note [Rebindable syntax for if]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 8ad8fe2..f14c490 100644 (file)
@@ -749,6 +749,10 @@ zonkExpr env (HsProc pat body)
         ; new_body <- zonkCmdTop env1 body
         ; return (HsProc new_pat new_body) }
 
+-- StaticPointers extension
+zonkExpr env (HsStatic expr)
+  = HsStatic <$> zonkLExpr env expr
+
 zonkExpr env (HsWrap co_fn expr)
   = do (env1, new_co_fn) <- zonkCoFn env co_fn
        new_expr <- zonkExpr env1 expr
index 6a52de9..8ad52ba 100644 (file)
@@ -464,6 +464,8 @@ tcRnSrcDecls boot_iface exports decls
       ; traceTc "Tc8" empty ;
       ; setEnvs (tcg_env, tcl_env) $
    do {
+        -- wanted constraints from static forms
+        stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
 
              --         Finish simplifying class constraints
              --
@@ -480,7 +482,7 @@ tcRnSrcDecls boot_iface exports decls
              --  * the local env exposes the local Ids to simplifyTop,
              --    so that we get better error messages (monomorphism restriction)
         new_ev_binds <- {-# SCC "simplifyTop" #-}
-                        simplifyTop lie ;
+                        simplifyTop (andWC stWC lie) ;
         traceTc "Tc9" empty ;
 
         failIfErrsM ;   -- Don't zonk if there have been errors
@@ -1669,9 +1671,12 @@ tcGhciStmts stmts
                         -- Look up the names right in the middle,
                         -- where they will all be in scope
 
+        -- wanted constraints from static forms
+        stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
+
         -- Simplify the context
         traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
-        const_binds <- checkNoErrs (simplifyInteractive lie) ;
+        const_binds <- checkNoErrs (simplifyInteractive (andWC stWC lie)) ;
                 -- checkNoErrs ensures that the plan fails if context redn fails
 
         traceTc "TcRnDriver.tcGhciStmts: done" empty ;
@@ -1756,7 +1761,11 @@ tcRnExpr hsc_env rdr_expr
                                                     False {- No MR for now -}
                                                     [(fresh_it, res_ty)]
                                                     lie ;
-    _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
+    -- wanted constraints from static forms
+    stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
+
+    -- Ignore the dictionary bindings
+    _ <- simplifyInteractive (andWC stWC lie_top) ;
 
     let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
     zonkTcType all_expr_ty
@@ -1833,7 +1842,11 @@ tcRnDeclsi hsc_env local_decls =
         captureConstraints $ tc_rn_src_decls emptyModDetails local_decls
     setEnvs (tcg_env, tclcl_env) $ do
 
-    new_ev_binds <- simplifyTop lie
+    -- wanted constraints from static forms
+    stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef
+
+    new_ev_binds <- simplifyTop (andWC stWC lie)
+
     failIfErrsM
     let TcGblEnv { tcg_type_env  = type_env,
                    tcg_binds     = binds,
index 2672067..dbc8b41 100644 (file)
@@ -94,6 +94,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                            Nothing             -> newIORef emptyNameEnv } ;
 
         dependent_files_var <- newIORef [] ;
+        static_wc_var       <- newIORef emptyWC ;
 #ifdef GHCI
         th_topdecls_var      <- newIORef [] ;
         th_topnames_var      <- newIORef emptyNameSet ;
@@ -161,7 +162,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                 tcg_main           = Nothing,
                 tcg_safeInfer      = infer_var,
                 tcg_dependent_files = dependent_files_var,
-                tcg_tc_plugins     = []
+                tcg_tc_plugins     = [],
+                tcg_static_wc      = static_wc_var
              } ;
              lcl_env = TcLclEnv {
                 tcl_errs       = errs_var,
index 9bc793a..17d84cb 100644 (file)
@@ -91,6 +91,7 @@ module TcRnTypes(
 #include "HsVersions.h"
 
 import HsSyn
+import CoreSyn
 import HscTypes
 import TcEvidence
 import Type
@@ -381,7 +382,10 @@ data TcGblEnv
                                              -- as -XSafe (Safe Haskell)
 
         -- | A list of user-defined plugins for the constraint solver.
-        tcg_tc_plugins :: [TcPluginSolver]
+        tcg_tc_plugins :: [TcPluginSolver],
+
+        tcg_static_wc :: TcRef WantedConstraints
+          -- ^ Wanted constraints of static forms.
     }
 
 -- Note [Signature parameters in TcGblEnv and DynFlags]
@@ -1904,6 +1908,7 @@ data CtOrigin
   | HoleOrigin
   | UnboundOccurrenceOf RdrName
   | ListOrigin          -- An overloaded list
+  | StaticOrigin        -- A static form
 
 ctoHerald :: SDoc
 ctoHerald = ptext (sLit "arising from")
@@ -1975,6 +1980,7 @@ pprCtO (TypeEqOrigin t1 t2)  = ptext (sLit "a type equality") <+> sep [ppr t1, c
 pprCtO AnnOrigin             = ptext (sLit "an annotation")
 pprCtO HoleOrigin            = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_")
 pprCtO ListOrigin            = ptext (sLit "an overloaded list")
+pprCtO StaticOrigin          = ptext (sLit "a static form")
 pprCtO _                     = panic "pprCtOrigin"
 
 {-
index 2c6cb6a..e12703f 100644 (file)
@@ -10388,6 +10388,131 @@ Assertion failures can be caught, see the documentation for the
 
 </sect1>
 
+<!-- =============================== STATIC POINTERS ===========================  -->
+
+<sect1 id="static-pointers">
+<title>Static pointers
+<indexterm><primary>Static pointers</primary></indexterm>
+</title>
+
+<para>
+The language extension <literal>-XStaticPointers</literal> adds a new
+syntactic form <literal>static <replaceable>e</replaceable></literal>,
+which stands for a reference to the closed expression
+<replaceable>e</replaceable>. This reference is stable and portable,
+in the sense that it remains valid across different processes on
+possibly different machines. Thus, a process can create a reference
+and send it to another process that can resolve it to
+<replaceable>e</replaceable>.
+</para>
+<para>
+With this extension turned on, <literal>static</literal> is no longer
+a valid identifier.
+</para>
+<para>
+Static pointers were first proposed in the paper <ulink
+url="http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf">
+Towards Haskell in the cloud</ulink>, Jeff Epstein, Andrew P. Black and Simon
+Peyton-Jones, Proceedings of the 4th ACM Symposium on Haskell, pp.
+118-129, ACM, 2011.
+</para>
+
+<sect2 id="using-static-pointers">
+<title>Using static pointers</title>
+
+<para>
+Each reference is given a key which can be used to locate it at runtime with
+<ulink url="&libraryBaseLocation;/GHC.StaticPtr.html#v%3AunsafeLookupStaticPtr"><literal>unsafeLookupStaticPtr</literal></ulink>
+which uses a global and immutable table called the Static Pointer Table.
+The compiler includes entries in this table for all static forms found in
+the linked modules. The value can be obtained from the reference via
+<ulink url="&libraryBaseLocation;/GHC.StaticPtr.html#v%3AdeRefStaticPtr"><literal>deRefStaticPtr</literal></ulink>
+</para>
+
+<para>
+The body <literal>e</literal> of a <literal>static
+e</literal> expression must be a closed expression. That is, there can
+be no free variables occurring in <literal>e</literal>, i.e. lambda-
+or let-bound variables bound locally in the context of the expression.
+</para>
+
+<para>
+All of the following are permissible:
+<programlisting>
+inc :: Int -> Int
+inc x = x + 1
+
+ref1 = static 1
+ref2 = static inc
+ref3 = static (inc 1)
+ref4 = static ((\x -> x + 1) (1 :: Int))
+ref5 y = static (let x = 1 in x)
+</programlisting>
+While the following definitions are rejected:
+<programlisting>
+ref6 = let x = 1 in static x
+ref7 y = static (let x = 1 in y)
+</programlisting>
+Note that currently, the body <literal>e</literal> in <literal>static
+e</literal> is restricted to a single identifier when at the GHCi
+prompt.
+</para>
+</sect2>
+
+<sect2 id="typechecking-static-pointers">
+<title>Static semantics of static pointers</title>
+
+<para>
+
+Informally, if we have a closed expression
+<programlisting>
+e :: forall a_1 ... a_n . t
+</programlisting>
+the static form is of type
+<programlisting>
+static e :: (Typeable a_1, ... , Typeable a_n) => StaticPtr t
+</programlisting>
+Furthermore, type <literal>t</literal> is constrained to have a
+<literal>Typeable</literal> instance.
+
+The following are therefore illegal:
+<programlisting>
+static show                    -- No Typeable instance for (Show a => a -> String)
+static Control.Monad.ST.runST  -- No Typeable instance for ((forall s. ST s a) -> a)
+</programlisting>
+
+That being said, with the appropriate use of wrapper datatypes, the
+above limitations induce no loss of generality:
+<programlisting>
+{-# LANGUAGE ConstraintKinds           #-}
+{-# LANGUAGE DerivingDataTypeable      #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE Rank2Types                #-}
+{-# LANGUAGE StandaloneDeriving        #-}
+{-# LANGUAGE StaticPointers            #-}
+
+import Control.Monad.ST
+import GHC.StaticPtr
+
+data Dict c = c => Dict
+  deriving Typeable
+
+g1 :: Typeable a => StaticPtr (Dict (Show a) -> a -> String)
+g1 = static (\Dict -> show)
+
+data Rank2Wrapper f = R2W (forall s. f s)
+  deriving Typeable
+newtype Flip f a s = Flip { unFlip :: f s a }
+  deriving Typeable
+
+g2 :: Typeable a => StaticPtr (Rank2Wrapper (Flip ST a) -> a)
+g2 = static (\(R2W f) -> runST (unFlip f))
+</programlisting>
+</para>
+</sect2>
+
+</sect1>
+
 
 <!-- =============================== PRAGMAS ===========================  -->
 
index d51ee04..20be360 100644 (file)
@@ -161,6 +161,10 @@ extern void hs_free_stable_ptr_unsafe (HsStablePtr sp);
 extern void hs_free_stable_ptr (HsStablePtr sp);
 extern void hs_free_fun_ptr    (HsFunPtr fp);
 
+extern StgPtr hs_spt_lookup(StgWord64 key[2]);
+extern int hs_spt_keys(StgPtr keys[], int szKeys);
+extern int hs_spt_key_count (void);
+
 /* -------------------------------------------------------------------------- */
 
 #ifdef __cplusplus
index 6bf7650..77eeb31 100644 (file)
@@ -238,6 +238,7 @@ INLINE_HEADER Time fsecondsToTime (double t)
 #include "rts/Utils.h"
 #include "rts/PrimFloat.h"
 #include "rts/Main.h"
+#include "rts/StaticPtrTable.h"
 
 /* Misc stuff without a home */
 DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell */
diff --git a/includes/rts/StaticPtrTable.h b/includes/rts/StaticPtrTable.h
new file mode 100644 (file)
index 0000000..8b56510
--- /dev/null
@@ -0,0 +1,32 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2008-2009
+ *
+ * Initialization of the Static Pointer Table
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef RTS_STATICPTRTABLE_H
+#define RTS_STATICPTRTABLE_H
+
+/** Inserts an entry in the Static Pointer Table.
+ *
+ * The key is a fingerprint computed from the StaticName of a static pointer
+ * and the spe_closure is a pointer to the closure defining the table entry
+ * (GHC.SptEntry).
+ *
+ * A stable pointer to the closure is made to prevent it from being garbage
+ * collected while the entry exists on the table.
+ *
+ * This function is called from the code generated by
+ * compiler/deSugar/StaticPtrTable.sptInitCode
+ *
+ * */
+void hs_spt_insert (StgWord64 key[2],void* spe_closure);
+
+#endif /* RTS_STATICPTRTABLE_H */
diff --git a/libraries/base/GHC/StaticPtr.hs b/libraries/base/GHC/StaticPtr.hs
new file mode 100644 (file)
index 0000000..b92b843
--- /dev/null
@@ -0,0 +1,122 @@
+{-# LANGUAGE DeriveDataTypeable        #-}
+{-# LANGUAGE MagicHash                 #-}
+{-# LANGUAGE UnboxedTuples             #-}
+{-# LANGUAGE ExistentialQuantification #-}
+-----------------------------------------------------------------------------
+-- |
+-- 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 and inmutable 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.
+--
+-----------------------------------------------------------------------------
+
+module GHC.StaticPtr
+  ( StaticPtr
+  , deRefStaticPtr
+  , StaticKey
+  , staticKey
+  , unsafeLookupStaticPtr
+  , StaticPtrInfo(..)
+  , staticPtrInfo
+  , staticPtrKeys
+  ) where
+
+import Data.Typeable       (Typeable)
+import Foreign.C.Types     (CInt(..))
+import Foreign.Marshal     (allocaArray, peekArray, withArray)
+import Foreign.Ptr         (castPtr)
+import GHC.Exts            (addrToAny#)
+import GHC.Ptr             (Ptr(..), nullPtr)
+import GHC.Fingerprint     (Fingerprint(..))
+import System.IO.Unsafe    (unsafePerformIO)
+
+
+-- | A reference to a value of type 'a'.
+data StaticPtr a = StaticPtr StaticKey StaticPtrInfo a
+  deriving Typeable
+
+-- | Dereferences a static pointer.
+deRefStaticPtr :: StaticPtr a -> a
+deRefStaticPtr (StaticPtr _ _ v) = v
+
+-- | A key for `StaticPtrs` 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 (StaticPtr k _ _) = k
+
+-- | 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 -> Maybe (StaticPtr a)
+unsafeLookupStaticPtr k = unsafePerformIO $ sptLookup k
+
+-- | Miscelaneous information available for debugging purposes.
+data StaticPtrInfo = StaticPtrInfo
+    { -- | PackageId of the package where the static pointer is defined
+      spInfoPackageId  :: String
+      -- | Name of the module where the static pointer is defined
+    , spInfoModuleName :: String
+      -- | An internal name that is distinct for every static pointer defined in
+      -- a given module.
+    , spInfoName       :: String
+      -- | Source location of the definition of the static pointer as a
+      -- @(Line, Column)@ pair.
+    , spIntoSrcLoc     :: (Int, Int)
+    }
+  deriving (Show, Typeable)
+
+-- | 'StaticPtrInfo' of the given 'StaticPtr'.
+staticPtrInfo :: StaticPtr a -> StaticPtrInfo
+staticPtrInfo (StaticPtr _ n _) = n
+
+-- | Like 'unsafeLookupStaticPtr' but evaluates in 'IO'.
+sptLookup :: StaticKey -> IO (Maybe (StaticPtr a))
+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)
+
+-- | A list of all known keys.
+staticPtrKeys :: [StaticKey]
+staticPtrKeys = unsafePerformIO $ do
+    keyCount <- hs_spt_key_count
+    allocaArray (fromIntegral keyCount) $ \p -> do
+      count <- hs_spt_keys p keyCount
+      peekArray (fromIntegral count) p >>=
+        mapM (\pa -> peekArray 2 pa >>= \[w1, w2] -> return $ Fingerprint w1 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
index e39a08d..c5c4a15 100644 (file)
@@ -255,6 +255,7 @@ Library
         GHC.Real
         GHC.RTS.Flags
         GHC.ST
+        GHC.StaticPtr
         GHC.STRef
         GHC.Show
         GHC.Stable
index 050ac85..b3ac97b 100644 (file)
@@ -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,
index bfba99a..8aed78d 100644 (file)
@@ -296,6 +296,10 @@ stringE = litE . stringL
 fieldExp :: Name -> ExpQ -> Q (Name, Exp)
 fieldExp s e = do { e' <- e; return (s,e') }
 
+-- | @staticE x = [| static x |]@
+staticE :: ExpQ -> ExpQ
+staticE = fmap StaticE
+
 -- ** 'arithSeqE' Shortcuts
 fromE :: ExpQ -> ExpQ
 fromE x = do { a <- x; return (ArithSeqE (FromR a)) }
index 5f3a0c6..0f828eb 100644 (file)
@@ -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)
index 0e5ced9..425834b 100644 (file)
@@ -1160,6 +1160,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)
index b91d70c..1881092 100644 (file)
@@ -206,6 +206,29 @@ lookupHashTable(HashTable *table, StgWord key)
     return NULL;
 }
 
+// Puts up to keys_sz keys of the hash table into the given array. Returns the
+// actual amount of keys that have been retrieved.
+//
+// If the table is modified concurrently, the function behavior is undefined.
+//
+int keysHashTable(HashTable *table, StgWord keys[], int szKeys) {
+    int segment;
+    int k = 0;
+    for(segment=0;segment<HDIRSIZE && table->dir[segment];segment+=1) {
+        int index;
+        for(index=0;index<HSEGSIZE;index+=1) {
+            HashList *hl;
+            for(hl=table->dir[segment][index];hl;hl=hl->next) {
+                if (k == szKeys)
+                  return k;
+                keys[k] = hl->key;
+                k += 1;
+            }
+        }
+    }
+    return k;
+}
+
 /* -----------------------------------------------------------------------------
  * We allocate the hashlist cells in large chunks to cut down on malloc
  * overhead.  Although we keep a free list of hashlist cells, we make
index d22caba..e802644 100644 (file)
@@ -21,6 +21,13 @@ void *      removeHashTable ( HashTable *table, StgWord key, void *data );
 
 int keyCountHashTable (HashTable *table);
 
+// Puts up to keys_sz keys of the hash table into the given array. Returns the
+// actual amount of keys that have been retrieved.
+//
+// If the table is modified concurrently, the function behavior is undefined.
+//
+int keysHashTable(HashTable *table, StgWord keys[], int szKeys);
+
 /* Hash table access where the keys are C strings (the strings are
  * assumed to be allocated by the caller, and mustn't be deallocated
  * until the corresponding hash table entry has been removed).
index 5c7a64e..4a0e5ea 100644 (file)
@@ -1418,6 +1418,10 @@ typedef struct _RtsSymbolVal {
       SymI_HasProto(stopProfTimer)                                      \
       SymI_HasProto(atomic_inc)                                         \
       SymI_HasProto(atomic_dec)                                         \
+      SymI_HasProto(hs_spt_lookup)                                      \
+      SymI_HasProto(hs_spt_insert)                                      \
+      SymI_HasProto(hs_spt_keys)                                        \
+      SymI_HasProto(hs_spt_key_count)                                   \
       RTS_USER_SIGNALS_SYMBOLS                                          \
       RTS_INTCHAR_SYMBOLS
 
index b8201e1..490f2ea 100644 (file)
@@ -32,6 +32,7 @@
 #include "sm/BlockAlloc.h"
 #include "Trace.h"
 #include "Stable.h"
+#include "StaticPtrTable.h"
 #include "Hash.h"
 #include "Profiling.h"
 #include "Timer.h"
@@ -395,6 +396,9 @@ hs_exit_(rtsBool wait_foreign)
     /* free file locking tables, if necessary */
     freeFileLocking();
 
+    /* free the Static Pointer Table */
+    exitStaticPtrTable();
+
     /* free the stable pointer table */
     exitStableTables();
 
diff --git a/rts/StaticPtrTable.c b/rts/StaticPtrTable.c
new file mode 100644 (file)
index 0000000..bd45080
--- /dev/null
@@ -0,0 +1,57 @@
+/*
+ * (c)2014 Tweag I/O
+ *
+ * The Static Pointer Table implementation.
+ *
+ * https://ghc.haskell.org/trac/ghc/wiki/StaticPointers
+ * https://ghc.haskell.org/trac/ghc/wiki/StaticPointers/ImplementationPlan
+ *
+ */
+
+#include "Rts.h"
+#include "StaticPtrTable.h"
+#include "Hash.h"
+
+static HashTable * spt = NULL;
+
+/// Hash function for the SPT.
+static int hashFingerprint(HashTable *table, StgWord64 key[2]) {
+  // Take half of the key to compute the hash.
+  return hashWord(table, (StgWord)key[1]);
+}
+
+/// Comparison function for the SPT.
+static int compareFingerprint(StgWord64 ptra[2], StgWord64 ptrb[2]) {
+  return ptra[0] == ptrb[0] && ptra[1] == ptrb[1];
+}
+
+void hs_spt_insert(StgWord64 key[2],void *spe_closure) {
+  // hs_spt_insert is called from constructor functions, so
+  // the SPT needs to be initialized here.
+  if (spt == NULL)
+    spt = allocHashTable_( (HashFunction *)hashFingerprint
+                         , (CompareFunction *)compareFingerprint
+                         );
+
+  getStablePtr(spe_closure);
+  insertHashTable(spt, (StgWord)key, spe_closure);
+}
+
+StgPtr hs_spt_lookup(StgWord64 key[2]) {
+  return spt ? lookupHashTable(spt, (StgWord)key) : NULL;
+}
+
+int hs_spt_keys(StgPtr keys[], int szKeys) {
+  return spt ? keysHashTable(spt, (StgWord*)keys, szKeys) : 0;
+}
+
+int hs_spt_key_count() {
+  return spt ? keyCountHashTable(spt) : 0;
+}
+
+void exitStaticPtrTable() {
+  if (spt) {
+    freeHashTable(spt, NULL);
+    spt = NULL;
+  }
+}
diff --git a/rts/StaticPtrTable.h b/rts/StaticPtrTable.h
new file mode 100644 (file)
index 0000000..4ad126c
--- /dev/null
@@ -0,0 +1,19 @@
+/*-----------------------------------------------------------------------------
+ *
+ * (c)2014 Tweag I/O
+ *
+ * Prototypes for StaticPtrTable.c
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef STATICPTRTABLE_H
+#define STATICPTRTABLE_H
+
+#include "BeginPrivate.h"
+
+/** Frees the Static Pointer Table. */
+void exitStaticPtrTable ( void );
+
+#include "EndPrivate.h"
+
+#endif /* STATICPTRTABLE_H */
diff --git a/testsuite/tests/codeGen/should_run/CgStaticPointers.hs b/testsuite/tests/codeGen/should_run/CgStaticPointers.hs
new file mode 100644 (file)
index 0000000..5576f43
--- /dev/null
@@ -0,0 +1,36 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StaticPointers     #-}
+
+-- | A test to use symbols produced by the static form.
+module Main(main) where
+
+import Data.Typeable
+import GHC.StaticPtr
+
+main :: IO ()
+main = do
+  print $ lookupKey (static (id . id)) (1 :: Int)
+  print $ lookupKey (static method :: StaticPtr (Char -> Int)) 'a'
+  print $ deRefStaticPtr (static g)
+  print $ deRefStaticPtr p0 'a'
+  print $ deRefStaticPtr (static t_field) $ T 'b'
+
+lookupKey :: StaticPtr a -> a
+lookupKey p = case unsafeLookupStaticPtr (staticKey p) of
+  Just p -> deRefStaticPtr p
+  Nothing -> error $ "couldn't find " ++ show (staticPtrInfo p)
+
+g :: String
+g = "found"
+
+p0 :: Typeable a => StaticPtr (a -> a)
+p0 = static (\x -> x)
+
+data T a = T { t_field :: a }
+  deriving Typeable
+
+class C1 a where
+  method :: a -> Int
+
+instance C1 Char where
+  method = const 0
diff --git a/testsuite/tests/codeGen/should_run/CgStaticPointers.stdout b/testsuite/tests/codeGen/should_run/CgStaticPointers.stdout
new file mode 100644 (file)
index 0000000..7b31e7f
--- /dev/null
@@ -0,0 +1,5 @@
+1
+0
+"found"
+'a'
+'b'
index f157287..89f6278 100644 (file)
@@ -114,6 +114,9 @@ test('T8103', only_ways(['normal']), compile_and_run, [''])
 test('T7953', reqlib('random'), compile_and_run, [''])
 test('T8256', reqlib('vector'), compile_and_run, [''])
 test('T6084',normal, compile_and_run, ['-O2'])
+test('CgStaticPointers',
+     [ when(compiler_lt('ghc', '7.9'), skip) ],
+     compile_and_run, [''])
 test('StaticArraySize', normal, compile_and_run, ['-O2'])
 test('StaticByteArraySize', normal, compile_and_run, ['-O2'])
 test('CopySmallArray', normal, compile_and_run, [''])
diff --git a/testsuite/tests/deSugar/should_run/DsStaticPointers.hs b/testsuite/tests/deSugar/should_run/DsStaticPointers.hs
new file mode 100644 (file)
index 0000000..7f61bc5
--- /dev/null
@@ -0,0 +1,30 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StaticPointers       #-}
+
+import Data.Typeable
+import GHC.StaticPtr
+
+main = putStr $ unlines $ map show names
+  where
+    names =
+      [ staticPtrInfo $ static g
+      , staticPtrInfo $ (static id :: StaticPtr (Int -> Int))
+      , staticPtrInfo $ (p0 :: StaticPtr (Int -> Int))
+      , staticPtrInfo $ (static method :: StaticPtr (Char -> Int))
+      , staticPtrInfo $ (static t_field :: StaticPtr (T Int -> Int))
+      ]
+
+g :: Int -> Int
+g = id
+
+p0 :: Typeable a => StaticPtr (a -> a)
+p0 = static (\x -> x)
+
+data T a = T { t_field :: a }
+  deriving Typeable
+
+class C1 a where
+  method :: a -> Int
+
+instance C1 Char where
+  method = const 0
diff --git a/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout b/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout
new file mode 100644 (file)
index 0000000..55ec658
--- /dev/null
@@ -0,0 +1,5 @@
+StaticPtrInfo {spInfoPackageId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:1", spIntoSrcLoc = (10,32)}
+StaticPtrInfo {spInfoPackageId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:2", spIntoSrcLoc = (11,33)}
+StaticPtrInfo {spInfoPackageId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:0", spIntoSrcLoc = (21,13)}
+StaticPtrInfo {spInfoPackageId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:3", spIntoSrcLoc = (13,33)}
+StaticPtrInfo {spInfoPackageId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:4", spIntoSrcLoc = (14,33)}
index 7e1618b..87ebe8e 100644 (file)
@@ -40,5 +40,7 @@ test('mc08', normal, compile_and_run, [''])
 test('T5742', normal, compile_and_run, [''])
 test('DsLambdaCase', when(compiler_lt('ghc', '7.5'), skip), compile_and_run, [''])
 test('DsMultiWayIf', when(compiler_lt('ghc', '7.5'), skip), compile_and_run, [''])
+test('DsStaticPointers',
+     when(compiler_lt('ghc', '7.9'), skip), compile_and_run, [''])
 test('T8952', normal, compile_and_run, [''])
 test('T9844', normal, compile_and_run, [''])
index 320238d..250eae1 100644 (file)
@@ -37,7 +37,8 @@ expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "JavaScriptFFI",
                              "PatternSynonyms",
                              "PartialTypeSignatures",
-                             "NamedWildcards"]
+                             "NamedWildcards",
+                             "StaticPointers"]
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",
diff --git a/testsuite/tests/parser/should_compile/RdrNoStaticPointers01.hs b/testsuite/tests/parser/should_compile/RdrNoStaticPointers01.hs
new file mode 100644 (file)
index 0000000..b6f0885
--- /dev/null
@@ -0,0 +1,7 @@
+-- Tests that when the StaticPointers extension is not enabled
+-- the static identifier can be used as a regular Haskell
+-- identifier.
+module RdrNoStaticPointers01 where
+
+f :: Int -> Int
+f static = static
index e9cc99e..13acedf 100644 (file)
@@ -96,4 +96,5 @@ test('T5243', extra_clean(['T5243A.hi', 'T5243A.o']),
      multimod_compile, ['T5243',''])
 test('T7118', normal, compile, [''])
 test('T7776', normal, compile, [''])
-test('T5682', normal, compile, [''])
\ No newline at end of file
+test('RdrNoStaticPointers01', when(compiler_lt('ghc', '7.9'), skip), compile, [''])
+test('T5682', normal, compile, [''])
diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail01.hs b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.hs
new file mode 100644 (file)
index 0000000..18631a2
--- /dev/null
@@ -0,0 +1,5 @@
+{-# LANGUAGE StaticPointers #-}
+
+module RnStaticPointersFail01 where
+
+f x = static x
diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr
new file mode 100644 (file)
index 0000000..b7ff89c
--- /dev/null
@@ -0,0 +1,6 @@
+
+RnStaticPointersFail01.hs:5:7:
+    Only identifiers of top-level bindings can appear in the body of the static form:
+      static x
+    but the following identifiers were found instead:
+      x
diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail02.hs b/testsuite/tests/rename/should_fail/RnStaticPointersFail02.hs
new file mode 100644 (file)
index 0000000..599cf53
--- /dev/null
@@ -0,0 +1,7 @@
+{-# LANGUAGE StaticPointers #-}
+
+module RnStaticPointersFail02 where
+
+f = static T
+
+data T = TDataCons
diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail02.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail02.stderr
new file mode 100644 (file)
index 0000000..6524702
--- /dev/null
@@ -0,0 +1,8 @@
+
+RnStaticPointersFail02.hs:5:5:
+    Only identifiers of top-level bindings can appear in the body of the static form:
+      static T
+    but the following identifiers were found instead:
+      T
+
+RnStaticPointersFail02.hs:5:12: Not in scope: data constructor ‘T’
diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs
new file mode 100644 (file)
index 0000000..1a9baa3
--- /dev/null
@@ -0,0 +1,5 @@
+{-# LANGUAGE StaticPointers #-}
+
+module RnStaticPointersFail03 where
+
+f x = static (x . id)
diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr
new file mode 100644 (file)
index 0000000..d5a7270
--- /dev/null
@@ -0,0 +1,6 @@
+
+RnStaticPointersFail03.hs:5:7:
+    Only identifiers of top-level bindings can appear in the body of the static form:
+      static (x . id)
+    but the following identifiers were found instead:
+      x
index d81b743..2798fe9 100644 (file)
@@ -112,6 +112,12 @@ test('T7937', normal, compile_fail, [''])
 test('T7943', normal, compile_fail, [''])
 test('T8448', normal, compile_fail, [''])
 test('T8149', normal, compile, [''])
+test('RnStaticPointersFail01',
+     when(compiler_lt('ghc', '7.9'), skip), compile_fail, [''])
+test('RnStaticPointersFail02',
+     when(compiler_lt('ghc', '7.9'), skip), compile_fail, [''])
+test('RnStaticPointersFail03',
+     when(compiler_lt('ghc', '7.9'), skip), compile_fail, [''])
 test('T9006',
      extra_clean(['T9006a.hi', 'T9006a.o']),
      multimod_compile_fail, ['T9006', '-v0'])
diff --git a/testsuite/tests/rts/GcStaticPointers.hs b/testsuite/tests/rts/GcStaticPointers.hs
new file mode 100644 (file)
index 0000000..7c2fc2b
--- /dev/null
@@ -0,0 +1,33 @@
+-- A test to show that -XStaticPointers keeps generated CAFs alive.
+{-# LANGUAGE StaticPointers #-}
+module Main where
+
+import GHC.StaticPtr
+
+import Control.Concurrent
+import Data.Maybe (fromJust)
+import GHC.Fingerprint
+import System.Mem
+import System.Mem.Weak
+import Unsafe.Coerce (unsafeCoerce)
+
+nats :: [Integer]
+nats = [0 .. ]
+
+-- Just a StaticPtr to some CAF so that we can deRef it.
+nats_fp :: StaticKey
+nats_fp = staticKey (static nats :: StaticPtr [Integer])
+
+main = do
+  let z = nats !! 400
+  print z
+  performGC
+  addFinalizer z (putStrLn "finalizer z")
+  print z
+  performGC
+  threadDelay 1000000
+  let Just p = unsafeLookupStaticPtr nats_fp
+  print (deRefStaticPtr (unsafeCoerce p) !! 800 :: Integer)
+  -- Uncommenting the next line keeps primes alive and would prevent a segfault
+  -- if nats were garbage collected.
+  -- print (nats !! 900)
diff --git a/testsuite/tests/rts/GcStaticPointers.stdout b/testsuite/tests/rts/GcStaticPointers.stdout
new file mode 100644 (file)
index 0000000..f3c61da
--- /dev/null
@@ -0,0 +1,3 @@
+400
+400
+800
diff --git a/testsuite/tests/rts/ListStaticPointers.hs b/testsuite/tests/rts/ListStaticPointers.hs
new file mode 100644 (file)
index 0000000..5ddb636
--- /dev/null
@@ -0,0 +1,26 @@
+-- A test to show that Static Pointers can be listed.
+{-# LANGUAGE StaticPointers #-}
+module Main where
+
+import Control.Monad (when)
+import Data.List ((\\))
+import GHC.StaticPtr
+import System.Exit
+
+main = when (not $ eqBags staticPtrKeys expected) $ do
+    print ("expected", expected)
+    print ("found", staticPtrKeys)
+    exitFailure
+  where
+
+    expected =
+      [ staticKey $  static (\x -> x :: Int)
+      , staticKey   (static return :: StaticPtr (Int -> IO Int))
+      , staticKey $  static g
+      ]
+
+    eqBags :: Eq a => [a] -> [a] -> Bool
+    eqBags xs ys = null (xs \\ ys) && null (ys \\ xs)
+
+g :: Int -> Int
+g = (+1)
index 7162f4c..b997a57 100644 (file)
@@ -243,6 +243,13 @@ test('rdynamic', [ unless(opsys('linux') or opsys('mingw32'), skip)
                  ],
      compile_and_run, ['-rdynamic -package ghc'])
 
+test('GcStaticPointers',
+     [ when(compiler_lt('ghc', '7.9'), skip) ],
+     compile_and_run, [''])
+test('ListStaticPointers',
+     [ when(compiler_lt('ghc', '7.9'), skip) ],
+     compile_and_run, [''])
+
 # 251 = RTS exit code for "out of memory"
 test('overflow1', [ exit_code(251) ], compile_and_run, [''])
 test('overflow2', [ exit_code(251) ], compile_and_run, [''])
diff --git a/testsuite/tests/th/TH_StaticPointers.hs b/testsuite/tests/th/TH_StaticPointers.hs
new file mode 100644 (file)
index 0000000..119fb8d
--- /dev/null
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StaticPointers #-}
+
+-- | A test of static forms in TH quotations.
+module Main(main) where
+
+import GHC.StaticPtr
+
+main = print $ deRefStaticPtr $([| static g :: StaticPtr String |])
+
+g = "found"
diff --git a/testsuite/tests/th/TH_StaticPointers.stdout b/testsuite/tests/th/TH_StaticPointers.stdout
new file mode 100644 (file)
index 0000000..e4c4f00
--- /dev/null
@@ -0,0 +1 @@
+"found"
diff --git a/testsuite/tests/th/TH_StaticPointers02.hs b/testsuite/tests/th/TH_StaticPointers02.hs
new file mode 100644 (file)
index 0000000..1f619a7
--- /dev/null
@@ -0,0 +1,21 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StaticPointers #-}
+
+-- | A test to try the static form in splices.
+--
+-- A static form is defined in a splice and then it is used in the program.
+--
+module Main(main) where
+
+import GHC.Fingerprint
+import GHC.StaticPtr
+
+main = print $ $(case staticKey (static 'a') of
+  Fingerprint w0 w1 ->
+    let w0i = fromIntegral w0 :: Integer
+        w1i = fromIntegral w1 :: Integer
+    in
+     [| fmap (\p -> deRefStaticPtr p :: Char) $ unsafeLookupStaticPtr $
+          Fingerprint (fromIntegral w0i) (fromIntegral w1i)
+      |]
+     )
diff --git a/testsuite/tests/th/TH_StaticPointers02.stderr b/testsuite/tests/th/TH_StaticPointers02.stderr
new file mode 100644 (file)
index 0000000..cc6fa82
--- /dev/null
@@ -0,0 +1,10 @@
+
+TH_StaticPointers02.hs:13:34:
+    static forms cannot be used in splices: static 'a'
+    In the splice:
+      $(case staticKey (static 'a') of {
+          Fingerprint w0 w1
+            -> let ...
+               in
+                 [| fmap (\ p -> ...) $ unsafeLookupStaticPtr
+                    $ Fingerprint (fromIntegral w0i) (fromIntegral w1i) |] })
index 8656fcb..4c8023e 100644 (file)
@@ -322,6 +322,12 @@ test('T8577',
      ['T8577', '-v0 ' + config.ghc_th_way_flags])
 test('T8633', normal, compile_and_run, [''])
 test('T8625', normal, ghci_script, ['T8625.script'])
+test('TH_StaticPointers',
+     [ when(compiler_lt('ghc', '7.9'), skip) ],
+     compile_and_run, [''])
+test('TH_StaticPointers02',
+     [ when(compiler_lt('ghc', '7.9'), skip) ],
+     compile_fail, [''])
 test('T8759', normal, compile_fail, ['-v0'])
 test('T8759a', normal, compile_fail, ['-v0'])
 test('T7021',
diff --git a/testsuite/tests/typecheck/should_compile/TcStaticPointers01.hs b/testsuite/tests/typecheck/should_compile/TcStaticPointers01.hs
new file mode 100644 (file)
index 0000000..a48568e
--- /dev/null
@@ -0,0 +1,17 @@
+{-# LANGUAGE StaticPointers #-}
+
+module StaticPointers01 where
+
+import GHC.StaticPtr
+
+f0 :: StaticPtr (Int -> Int)
+f0 = static g
+
+f1 :: StaticPtr (Bool -> Bool -> Bool)
+f1 = static (&&)
+
+f2 :: StaticPtr (Bool -> Bool -> Bool)
+f2 = static ((&&) . id)
+
+g :: Int -> Int
+g = id
diff --git a/testsuite/tests/typecheck/should_compile/TcStaticPointers02.hs b/testsuite/tests/typecheck/should_compile/TcStaticPointers02.hs
new file mode 100644 (file)
index 0000000..9b51aee
--- /dev/null
@@ -0,0 +1,37 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StaticPointers     #-}
+
+module StaticPointers02 where
+
+import GHC.StaticPtr
+import Data.Typeable
+
+f2 :: Typeable a => StaticPtr (a -> a)
+f2 = static id
+
+f3 :: StaticPtr (Char -> Int)
+f3 = static method
+
+f4 :: Typeable a => StaticPtr (T a -> a)
+f4 = static t_field
+
+g :: Int -> Int
+g = id
+
+f5 :: Typeable a => StaticPtr (a -> a)
+f5 = static (id . id)
+
+f6 :: Typeable a => StaticPtr (a -> IO a)
+f6 = static return
+
+f7 :: Typeable a => StaticPtr (a -> IO a)
+f7 = static (\x -> getLine >> return x)
+
+data T a = T { t_field :: a }
+  deriving Typeable
+
+class C a where
+  method :: a -> Int
+
+instance C Char where
+  method = const 0
index e1f4c3f..4a28032 100644 (file)
@@ -416,6 +416,8 @@ test('T8474', normal, compile, [''])
 test('T8563', normal, compile, [''])
 test('T8565', normal, compile, [''])
 test('T8644', normal, compile, [''])
+test('TcStaticPointers01', when(compiler_lt('ghc', '7.9'), skip), compile, [''])
+test('TcStaticPointers02', when(compiler_lt('ghc', '7.9'), skip), compile, [''])
 test('T8762', normal, compile, [''])
 test('MutRec', normal, compile, [''])
 test('T8856', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.hs b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.hs
new file mode 100644 (file)
index 0000000..7221b73
--- /dev/null
@@ -0,0 +1,11 @@
+{-# LANGUAGE StaticPointers   #-}
+
+module StaticPointersFail01 where
+
+import GHC.StaticPtr
+
+f0 :: StaticPtr Int
+f0 = static g
+
+g :: Int -> Int
+g = id
diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.stderr b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.stderr
new file mode 100644 (file)
index 0000000..e41ec74
--- /dev/null
@@ -0,0 +1,6 @@
+
+TcStaticPointersFail01.hs:8:13:
+    Couldn't match expected type ‘Int’ with actual type ‘Int -> Int’
+    Probable cause: ‘g’ is applied to too few arguments
+    In the body of a static form: g
+    In the expression: static g
diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.hs b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.hs
new file mode 100644 (file)
index 0000000..3b4d0ff
--- /dev/null
@@ -0,0 +1,12 @@
+{-# LANGUAGE StaticPointers     #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+
+module StaticPointersFail02 where
+
+import GHC.StaticPtr
+
+f1 :: StaticPtr ((forall a . a -> a) -> b)
+f1 = static (undefined :: (forall a . a -> a) -> b)
+
+f2 :: StaticPtr (Monad m => a -> m a)
+f2 = static return
diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr
new file mode 100644 (file)
index 0000000..f11ec28
--- /dev/null
@@ -0,0 +1,14 @@
+
+TcStaticPointersFail02.hs:9:6:
+    No instance for (Data.Typeable.Internal.Typeable b)
+      arising from a static form
+    In the expression: static (undefined :: (forall a. a -> a) -> b)
+    In an equation for ‘f1’:
+       f1 = static (undefined :: (forall a. a -> a) -> b)
+
+TcStaticPointersFail02.hs:12:6:
+    No instance for (Data.Typeable.Internal.Typeable Monad)
+      (maybe you haven't applied enough arguments to a function?)
+      arising from a static form
+    In the expression: static return
+    In an equation for ‘f2’: f2 = static return
diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.hs b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.hs
new file mode 100644 (file)
index 0000000..58e06ee
--- /dev/null
@@ -0,0 +1,9 @@
+{-# LANGUAGE StaticPointers     #-}
+
+module StaticPointersFail03 where
+
+import GHC.StaticPtr
+import Data.Typeable
+
+f1 :: (Typeable a, Typeable m, Monad m) => a -> m a
+f1 = deRefStaticPtr (static return)
diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr
new file mode 100644 (file)
index 0000000..03a01df
--- /dev/null
@@ -0,0 +1,6 @@
+
+TcStaticPointersFail03.hs:9:29:
+    No instance for (Monad m) arising from a use of ‘return’
+    In the body of a static form: return
+    In the first argument of ‘deRefStaticPtr’, namely ‘(static return)’
+    In the expression: deRefStaticPtr (static return)
index d3c8941..1546b3a 100644 (file)
@@ -328,6 +328,12 @@ test('ContextStack2', normal, compile_fail, ['-ftype-function-depth=10'])
 test('T8570', extra_clean(['T85570a.o', 'T8570a.hi','T85570b.o', 'T8570b.hi']),
      multimod_compile_fail, ['T8570', '-v0'])
 test('T8603', normal, compile_fail, [''])
+test('TcStaticPointersFail01',
+     when(compiler_lt('ghc', '7.9'), skip), compile_fail, [''])
+test('TcStaticPointersFail02',
+     when(compiler_lt('ghc', '7.9'), skip), compile_fail, [''])
+test('TcStaticPointersFail03',
+     when(compiler_lt('ghc', '7.9'), skip), compile_fail, [''])
 test('T8806', normal, compile_fail, [''])
 test('T8912', normal, compile_fail, [''])
 test('T9033', normal, compile_fail, [''])