Implement -XStaticValues.wip/static-pointers

Contains contributions from Alexander Vershilov and Mathieu Boespflug.

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.

In essence the extension collects the arguments of the static form into
a global static pointer table. The expressions can be looked up by a
fingerprint computed from the package, the module and a fresh name
given to the expression. For more details we refer to the users guide
section contained in the patch.

The extension is a contribution to the Cloud Haskell ecosystem
(distributed-process and related), and thus has the potential to foster
Haskell as a programming language for distributed systems.

The immediate improvement brought by the extension is the elimination of
remote tables from Cloud Haskell applications. Such applications contain
table fragments spread throughout multiple modules and packages.
Eliminating these fragments saves the programmer the burden required to
construct and assemble the global remote table, a verbose and
error-prone process, even with the help of Template Haskell, that
moreover pollutes the export lists of all modules.

[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.

24 files changed, 506 insertions, 27 deletions

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 5e7289f00c..935f24e36b 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -534,6 +534,9 @@ addTickHsExpr (ExplicitPArr ty es) =
         liftM2 ExplicitPArr
                 (return ty)
                 (mapM (addTickLHsExpr) es)
+
+addTickHsExpr e@(HsStatic _) = return e
+
 addTickHsExpr (RecordCon id ty rec_binds) =
         liftM3 RecordCon
                 (return id)
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index e2170e7dd4..2ec2aebbe8 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -49,6 +49,7 @@ import Coverage
 import Util
 import MonadUtils
 import OrdList
+import SPT
 import Data.List
 import Data.IORef
 import Control.Monad( when )
@@ -91,7 +92,8 @@ deSugar hsc_env
                             tcg_tcs          = tcs,
                             tcg_insts        = insts,
                             tcg_fam_insts    = fam_insts,
-                            tcg_hpc          = other_hpc_info })
+                            tcg_hpc          = other_hpc_info,
+                            tcg_static_binds = static_binds_var })
 
   = do { let dflags = hsc_dflags hsc_env
              print_unqual = mkPrintUnqualified dflags rdr_env
@@ -121,23 +123,36 @@ deSugar hsc_env
                           ; (ds_fords, foreign_prs) <- dsForeigns fords
                           ; ds_rules <- mapMaybeM dsRule rules
                           ; ds_vects <- mapM dsVect vects
+                          ; stBinds <- dsGetStaticBindsVar >>= liftIO . readIORef
+                          ; let core_prs' = core_prs `appOL` toOL stBinds
                           ; let hpc_init
                                   | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
                                   | otherwise = empty
+                          ; -- Collects the sptEntries of the module
+                            let spt_init = sptInitCode mod stBinds
                           ; return ( ds_ev_binds
-                                   , foreign_prs `appOL` core_prs `appOL` spec_prs
+                                   , foreign_prs `appOL` core_prs' `appOL` spec_prs
                                    , 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) ;
-           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do
+           Just (ds_ev_binds, all_prs, {-st_binds,-} all_rules, vects0, ds_fords) ->
 
-     do {       -- Add export flags to bindings
-          keep_alive <- readIORef keep_var
+     do { st_binds' <- readIORef static_binds_var
+          -- Add export flags to bindings
+        ; keep_alive <- readIORef keep_var
+        -- ; let static_names = map (map (idName . fst)) $ [ st_binds', st_binds ]
+        --      keep_alive_all = foldl addListToNameSet keep_alive static_names
         ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
-              final_prs = addExportFlagsAndRules target export_set keep_alive
-                                                 rules_for_locals (fromOL all_prs)
+              final_prs = addExportFlagsAndRules
+                            target export_set keep_alive
+                            rules_for_locals $ fromOL $ all_prs
+
+                            -- target export_set keep_alive_all
+                            -- rules_for_locals $ fromOL $
+                            --   all_prs `appOL`
+                            --  toOL st_binds' `appOL` toOL st_binds
 
               final_pgm = combineEvBinds ds_ev_binds final_prs
         -- Notice that we put the whole lot in a big Rec, even the foreign binds
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index ce2d5a5d4a..e9c06fa812 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -62,6 +62,10 @@ import Bag
 import Outputable
 import FastString
 
+import IdInfo
+-- import Module ( HasModule(..), lookupWithDefaultModuleEnv, extendModuleEnv )
+import Data.IORef       ( atomicModifyIORef, modifyIORef )
+
 import Control.Monad
 \end{code}
 
@@ -413,6 +417,51 @@ dsExpr (PArrSeq _ _)
 \end{code}
 
 \noindent
+\underline{\bf Static Pointers}
+%              ~~~~~~~~~~~~~~~
+\begin{verbatim}
+    static f
+==>
+    StaticPtr (StaticName "pkg id of f" "module of f" "f")
+\end{verbatim}
+
+\begin{code}
+dsExpr (HsStatic expr@(L loc _)) = do
+    expr_ds <- dsLExpr expr
+    let ty = exprType expr_ds
+    case dropTypeApps expr_ds of
+      Var _ -> return ()
+      _ -> do
+        failWithDs $ cat
+          [ ptext (sLit "The argument of a static form can be only a name")
+          , ptext (sLit "but found: static") <+> parens (ppr expr)
+          ]
+    n' <- mkSptEntryName loc
+    static_binds_var <- dsGetStaticBindsVar
+
+    let mod = nameModule n'
+        pkgKey = modulePackageKey mod
+        pkgName = packageKeyString pkgKey
+
+    -- create static name
+    nm <- fmap (mkConApp staticNameDataCon) $
+            mapM mkStringExprFS
+                 [ fsLit pkgName
+                 , moduleNameFS $ moduleName mod
+                 , occNameFS $ nameOccName n'
+                 ]
+    let tvars = varSetElems $ tyVarsOfType ty
+        speId = mkExportedLocalId VanillaId n' staticSptEntryTy
+        spe   = mkConApp staticSptEntryDataCon
+                  [Type (mkForAllTys tvars ty), nm, mkLams tvars expr_ds]
+    liftIO $ modifyIORef static_binds_var ((speId, spe) :)
+    putSrcSpanDs loc $ return $ mkConApp staticPtrDataCon [Type ty, nm, expr_ds]
+  where
+    dropTypeApps (App e (Type _)) = dropTypeApps e
+    dropTypeApps e = e
+\end{code}
+
+\noindent
 \underline{\bf Record construction and update}
 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 For record construction we do this (assuming T has three arguments)
@@ -887,3 +936,32 @@ badMonadBind rhs elt_ty flag_doc
               2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs)
          , ptext (sLit "or by using the flag") <+>  flag_doc ]
 \end{code}
+
+%************************************************************************
+%*                                                                      *
+\subsection{Static pointers}
+%*                                                                      *
+%************************************************************************
+
+
+-- mkStaticRhs :: CoreExpr ->
+
+\begin{code}
+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
+\end{code}
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 083c466baa..e344070df1 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1075,6 +1075,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)
@@ -2105,7 +2106,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
@@ -2287,7 +2288,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
@@ -2318,6 +2319,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
@@ -2657,7 +2659,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
@@ -2684,6 +2686,7 @@ listEIdKey        = mkPreludeMiscIdUnique 292
 sigEIdKey         = mkPreludeMiscIdUnique 293
 recConEIdKey      = mkPreludeMiscIdUnique 294
 recUpdEIdKey      = mkPreludeMiscIdUnique 295
+staticEIdKey      = mkPreludeMiscIdUnique 296
 
 -- type FieldExp = ...
 fieldExpIdKey :: Unique
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index c017a7cc01..ea4f581880 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -21,7 +21,7 @@ module DsMonad (
         mkPrintUnqualifiedDs,
         newUnique, 
         UniqSupply, newUniqueSupply,
-        getGhcModeDs, dsGetFamInstEnvs,
+        getGhcModeDs, dsGetFamInstEnvs, dsGetStaticBindsVar,
         dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
         
         PArrBuiltin(..), 
@@ -167,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 [(Id,CoreExpr)]
+          -- ^ Bindings resulted from floating static forms
         }
 
 instance ContainsModule DsGblEnv where
@@ -197,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 $
@@ -276,12 +281,15 @@ initDsTc thing_inside
         ; 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
+              static_binds_var = tcg_static_binds tcg_env
+              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 [(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
@@ -291,6 +299,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
@@ -496,6 +505,9 @@ dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env
 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 dsExtendMetaEnv menv thing_inside
   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
+
+dsGetStaticBindsVar :: DsM (IORef [(Id,CoreExpr)])
+dsGetStaticBindsVar = fmap ds_static_binds getGblEnv
 \end{code}
 
 \begin{code}
diff --git a/compiler/deSugar/SPT.lhs b/compiler/deSugar/SPT.lhs
new file mode 100644
index 0000000000..b5823413e0
--- /dev/null
+++ b/compiler/deSugar/SPT.lhs
@@ -0,0 +1,88 @@
+%
+% Code generation for the Static Pointer Table
+%
+% (c) 2014 I/O Tweag
+%
+\begin{code}
+module SPT (sptInitCode) where
+
+import CoreSyn
+import Module
+import Outputable
+import Id
+import Name
+import CLabel
+import FastString
+import Foreign.Ptr
+import GHC.Fingerprint
+import qualified Data.ByteString.Unsafe as BS
+import System.IO.Unsafe (unsafePerformIO)
+\end{code}
+
+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)
+{
+ extern StgPtr Main_sptEntryZC0_closure;
+ extern StgPtr Main_sptEntryZC1_closure;
+ hs_spt_insert( (StgWord64[2]){16252233376642134256ULL,7370534374097506082ULL}
+              , &Main_sptEntryZC0_closure
+              );
+ hs_spt_insert( (StgWord64[2]){12545634534567898323ULL,5409674567544156781ULL}
+              , &Main_sptEntryZC1_closure
+              );
+}
+
+where constants are values of a fingerprint of the triplet
+(package_id, module_name, sptEntry:N).
+
+\begin{code}
+sptInitCode :: Module -> [(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 $
+        [  ptext (sLit "extern StgPtr ")
+        <> (ppr $ mkClosureLabel (idName n) (idCafInfo n))
+        <> semi
+        |  (n, _) <- entries ] ++
+        [  ptext (sLit "hs_spt_insert")
+        <> parens (hcat $ punctuate comma
+            [ pprFingerprint $ fingerprintId n
+            , ptext (sLit "&") <> ppr (mkClosureLabel (idName n) (idCafInfo n))
+            ])
+        <> semi
+        |  (n, _) <- entries ]
+    ]
+\end{code}
+
+\begin{code}
+fingerprintId :: Id -> Fingerprint
+fingerprintId n =
+   fingerprintString (unpackFS name)
+ where
+   name = concatFS [ packageKeyFS $ modulePackageKey $ nameModule $ idName n
+                   , fsLit ":"
+                   , moduleNameFS (moduleName $ nameModule $ idName n)
+                   , fsLit "."
+                   , occNameFS $ occName $ idName n
+                   ]
+
+pprFingerprint :: Fingerprint -> SDoc
+pprFingerprint (Fingerprint w1 w2) =
+   ptext (sLit "(StgWord64[2])")
+   <> (braces $ hcat $ punctuate comma [integer (fromIntegral w1) <> ptext  (sLit "ULL")
+                                       ,integer (fromIntegral w2) <> ptext (sLit "ULL")
+                                       ])
+\end{code}
+
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 6422eb7ce9..6d167e5dba 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -319,6 +319,7 @@ Library
         PlatformConstants
         PprTyThing
         StaticFlags
+        SPT
         SysTools
         TidyPgm
         Ctype
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 9ad594c698..896bc69622 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -673,6 +673,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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index eaac719df9..b9547db9b6 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -277,6 +277,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
@@ -567,6 +571,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
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 043174f3b0..e170b8f72c 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -604,6 +604,7 @@ data ExtensionFlag
    | Opt_NegativeLiterals
    | Opt_EmptyCase
    | Opt_PatternSynonyms
+   | Opt_StaticPointers
    deriving (Eq, Enum, Show)
 
 data SigOf = NotSigOf
@@ -2960,7 +2961,8 @@ xFlags = [
   ( "UndecidableInstances",             Opt_UndecidableInstances, nop ),
   ( "UnicodeSyntax",                    Opt_UnicodeSyntax, nop ),
   ( "UnliftedFFITypes",                 Opt_UnliftedFFITypes, nop ),
-  ( "ViewPatterns",                     Opt_ViewPatterns, nop )
+  ( "ViewPatterns",                     Opt_ViewPatterns, nop ),
+  ( "StaticPointers",                   Opt_StaticPointers, nop )
   ]
 
 defaultFlags :: Settings -> [GeneralFlag]
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 6d05bb9d6d..d2803dbc3f 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -545,6 +545,7 @@ data Token
   | ITby
   | ITusing
   | ITpattern
+  | ITstatic
 
   -- Pragmas
   | ITinline_prag InlineSpec RuleMatchInfo
@@ -728,6 +729,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),
@@ -1100,6 +1102,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
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 2e1b777bb3..096d1d998b 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -273,6 +273,7 @@ incorrect.
  '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 }
@@ -1599,6 +1600,7 @@ hpc_annot :: { Located (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 }
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 6e40546d2c..e7464a2a19 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -452,6 +452,9 @@ gHC_IP          = mkBaseModule (fsLit "GHC.IP")
 gHC_PARR' :: Module
 gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
 
+gHC_STATICPTR :: Module
+gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")
+
 mAIN, rOOT_MAIN :: Module
 mAIN            = mkMainModule_ mAIN_NAME
 rOOT_MAIN       = mkMainModule (fsLit ":Main") -- Root module for initialisation
@@ -1483,6 +1486,18 @@ specTyConKey = mkPreludeTyConUnique 177
 smallArrayPrimTyConKey        = mkPreludeTyConUnique  178
 smallMutableArrayPrimTyConKey = mkPreludeTyConUnique  179
 
+staticPtrTyConKey  :: Unique
+staticPtrTyConKey  = mkPreludeTyConUnique 180
+
+staticNameTyConKey :: Unique
+staticNameTyConKey = mkPreludeTyConUnique 181
+
+staticSptEntryTyConKey :: Unique
+staticSptEntryTyConKey = mkPreludeTyConUnique 182
+
+staticSptEntryConKey   :: Unique
+staticSptEntryConKey  = mkPreludeTyConUnique 183
+
 ---------------- Template Haskell -------------------
 --      USES TyConUniques 200-299
 -----------------------------------------------------
@@ -1545,6 +1560,16 @@ eqDataConKey                            = mkPreludeDataConUnique 28
 gtDataConKey                            = mkPreludeDataConUnique 29
 
 coercibleDataConKey                     = mkPreludeDataConUnique 32
+
+staticPtrDataConKey :: Unique
+staticPtrDataConKey                     = mkPreludeDataConUnique 33
+
+staticNameDataConKey :: Unique
+staticNameDataConKey                    = mkPreludeDataConUnique 34
+
+staticSptConKey :: Unique
+staticSptConKey                         = mkPreludeDataConUnique 35
+
 \end{code}
 
 %************************************************************************
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index f4dca9a0de..e7dd7df46c 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -1,4 +1,4 @@
-%
+, alpha%
 % (c) The GRASP Project, Glasgow University, 1994-1998
 %
 \section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types}
@@ -67,6 +67,12 @@ module TysWiredIn (
         parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon,
         parrTyCon_RDR, parrTyConName,
 
+        -- * StaticPtr
+        staticPtrTyCon, staticPtrTyConName,
+        staticPtrDataCon, staticNameDataCon,
+        staticSptEntryTy, staticSptEntryTyCon,
+        staticSptEntryTyConName, staticSptEntryDataCon,
+
         -- * Equality predicates
         eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon,
         coercibleTyCon, coercibleDataCon, coercibleClass,
@@ -151,6 +157,8 @@ wiredInTyCons = [ unitTyCon     -- Not treated like other tuples, because
               , wordTyCon
               , listTyCon
               , parrTyCon
+              , staticPtrTyCon
+              , staticNameTyCon
               , eqTyCon
               , coercibleTyCon
               , typeNatKindCon
@@ -216,6 +224,24 @@ parrTyConName   = mkWiredInTyConName   BuiltInSyntax
 parrDataConName = mkWiredInDataConName UserSyntax
                     gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon
 
+staticPtrTyConName, staticPtrDataConName :: Name
+staticPtrTyConName   = mkWiredInTyConName UserSyntax
+    gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey staticPtrTyCon
+staticPtrDataConName = mkWiredInDataConName UserSyntax
+    gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey staticPtrDataCon
+
+staticNameTyConName, staticNameDataConName :: Name
+staticNameTyConName   = mkWiredInTyConName UserSyntax
+    gHC_STATICPTR (fsLit "StaticName") staticNameTyConKey staticNameTyCon
+staticNameDataConName = mkWiredInDataConName UserSyntax
+    gHC_STATICPTR (fsLit "StaticName") staticNameDataConKey staticNameDataCon
+
+staticSptEntryTyConName, staticSptEntryDataConName :: Name
+staticSptEntryTyConName = mkWiredInTyConName UserSyntax
+    gHC_STATICPTR (fsLit "SptEntry") staticSptEntryTyConKey staticSptEntryTyCon
+staticSptEntryDataConName = mkWiredInDataConName UserSyntax
+    gHC_STATICPTR (fsLit "SptEntry") staticSptEntryConKey staticNameDataCon
+
 boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR,
     intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, eqTyCon_RDR :: RdrName
 boolTyCon_RDR   = nameRdrName boolTyConName
@@ -850,6 +876,64 @@ isPArrFakeCon      :: DataCon -> Bool
 isPArrFakeCon dcon  = dcon == parrFakeCon (dataConSourceArity dcon)
 \end{code}
 
+StaticPtr
+
+\begin{code}
+staticPtrTyCon :: TyCon
+staticPtrTyCon  =
+    pcNonRecDataTyCon staticPtrTyConName Nothing alpha_tyvar [staticPtrDataCon]
+
+staticPtrDataCon :: DataCon
+staticPtrDataCon  =
+    pcDataCon staticPtrDataConName alpha_tyvar [staticNameTy, alphaTy] staticPtrTyCon
+
+staticNameTy :: Type
+staticNameTy = mkTyConTy staticNameTyCon
+
+staticNameTyCon :: TyCon
+staticNameTyCon  =
+    pcNonRecDataTyCon staticNameTyConName Nothing [] [staticNameDataCon]
+
+staticNameDataCon :: DataCon
+staticNameDataCon  =
+    pcDataCon staticNameDataConName [] (replicate 3 stringTy) staticNameTyCon
+
+staticSptEntryTy :: Type
+staticSptEntryTy = mkTyConTy staticSptEntryTyCon
+
+staticSptEntryTyCon :: TyCon
+staticSptEntryTyCon =
+    pcNonRecDataTyCon staticSptEntryTyConName Nothing [] [staticSptEntryDataCon]
+
+staticSptEntryDataCon :: DataCon
+staticSptEntryDataCon =
+    let dc_name  = staticSptEntryDataConName
+        arg_tys  = [ staticNameTy, alphaTy ]
+        modu     = ASSERT( isExternalName dc_name )
+                   nameModule dc_name
+        wrk_key  = incrUnique (nameUnique dc_name)
+        wrk_occ  = mkDataConWorkerOcc (nameOccName dc_name)
+        wrk_name = mkWiredInName modu wrk_occ wrk_key
+                             (AnId (dataConWorkId data_con)) UserSyntax
+        data_con = mkDataCon
+          dc_name
+          False
+          (map (const HsNoBang) arg_tys)
+          []       -- No labelled fields
+          []       -- No univerally quantified type variables
+          [alphaTyVar] -- Existentially quantified type variables
+          []       -- No equality spec
+          []       -- No theta
+          arg_tys  -- Argument types
+          staticSptEntryTy -- Result type
+          staticSptEntryTyCon -- Representation type constructor
+          []      -- No stupid theta
+          (mkDataConWorkId wrk_name data_con) -- Worker Id
+          NoDataConRep    -- No data constructor representation
+
+     in data_con
+\end{code}
+
 Promoted Booleans
 
 \begin{code}
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index b24956c85e..be9d9116d8 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -310,6 +310,39 @@ 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.
+
+\begin{code}
+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.
+      _ -> do
+       let isTopLevelName n = isExternalName n || isWiredInName n
+       case nameSetToList $ filterNameSet (not . isTopLevelName) fvExpr of
+         [] -> return ()
+         fvNonGlobal -> addErr $ cat
+             [ ptext $ sLit $ "Only identifiers of top-level bindings can "
+                           ++ "appear in the body of the static form:"
+             , nest 2 $ ppr e
+             , ptext $ sLit "but the following identifiers were found instead:"
+             , nest 2 $ vcat $ map ppr fvNonGlobal
+             ]
+    return (HsStatic expr', fvExpr)
+\end{code}
+
+%************************************************************************
+%*                                                                      *
         Arrow notation
 %*                                                                      *
 %************************************************************************
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index c2af40703d..26c6e76f3d 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -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 )
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index a242ed77d2..ee73e5dc9f 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -23,6 +23,7 @@ import HsSyn
 import TcHsSyn
 import TcRnMonad
 import TcUnify
+import TcValidity
 import BasicTypes
 import Inst
 import TcBinds
@@ -38,6 +39,9 @@ import DsMonad hiding (Splice)
 import Id
 import ConLike
 import DataCon
+-- import IdInfo
+-- import Module ( HasModule(..), lookupWithDefaultModuleEnv, extendModuleEnv )
+-- import Data.IORef       ( atomicModifyIORef )
 import PatSyn
 import RdrName
 import Name
@@ -484,6 +488,32 @@ tcExpr (HsDo do_or_lc stmts _) res_ty
 tcExpr (HsProc pat cmd) res_ty
   = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
         ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
+
+tcExpr (HsStatic expr@(L loc _)) res_ty
+  = do  { (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty
+        ; (((expr',errCtx), untch), lie) <- captureConstraints $
+                                            captureUntouchables $
+            addErrCtxt (hang (ptext (sLit "In the body of a static form:"))
+                             2 (ppr expr)
+                       ) $
+            liftM2 (,) (tcPolyExprNC expr expr_ty) getErrCtxt
+        ; lieTcRef <- tcl_lie <$> getLclEnv
+        ; updTcRef lieTcRef (`andWC` lie)
+        -- Keep the name in case it is not used anywhere else.
+        ; case expr of
+            L _ (HsVar n) -> keepAlive n
+            _             -> return ()
+        -- Require the type of the argument to be Typeable.
+        ; (typeableClass, _) <- tcClass typeableClassName
+        ; _ <- instCall StaticOrigin [expr_ty]
+                [ mkTyConApp (classTyCon typeableClass)
+                             [liftedTypeKind, expr_ty]
+                ]
+        -- Insert the static form in a global list for later validation.
+        ; stOccsVar <- tcg_static_occs <$> getGblEnv
+        ; updTcRef stOccsVar ((expr_ty, lie, untch, loc, errCtx) :)
+        ; return $ mkHsWrapCo co $ HsStatic expr'
+        }
 \end{code}
 
 Note [Rebindable syntax for if]
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 1a91f10e66..23407639f2 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -736,6 +736,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
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index d6f237f64f..c6363c9811 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -15,7 +15,7 @@ module TcHsType (
                 -- Type checking type and class decls
         kcLookupKind, kcTyClTyVars, tcTyClTyVars,
         tcHsConArgType, tcDataKindSig,
-        tcClassSigType,
+        tcClassSigType, tcClass,
 
                 -- Kind-checking types
                 -- No kind generalisation, no checkValidType
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 893e0290da..730db77c7b 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -37,6 +37,9 @@ import TcHsSyn
 import TcExpr
 import TcRnMonad
 import TcEvidence
+import TcType (Untouchables)
+import TysWiredIn (staticPtrTyCon)
+import TcValidity
 import PprTyThing( pprTyThing )
 import Coercion( pprCoAxiom )
 import FamInst
@@ -473,6 +476,12 @@ tcRnSrcDecls boot_iface decls
                         simplifyTop lie ;
         traceTc "Tc9" empty ;
 
+        failIfErrsM ;
+
+        ((), lie2) <- captureConstraints checkStaticPointers ;
+        new_ev_binds2 <- {-# SCC "simplifyTop" #-}
+                         simplifyTop lie2 ;
+
         failIfErrsM ;   -- Don't zonk if there have been errors
                         -- It's a waste of time; and we may get debug warnings
                         -- about strangely-typed TyCons!
@@ -488,7 +497,8 @@ tcRnSrcDecls boot_iface decls
                          tcg_rules     = rules,
                          tcg_vects     = vects,
                          tcg_fords     = fords } = tcg_env
-            ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
+            ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
+                                          `unionBags` new_ev_binds2 } ;
 
         (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
             <- {-# SCC "zonkTopDecls" #-}
@@ -1641,8 +1651,11 @@ tcGhciStmts stmts
         -- OK, we're ready to typecheck the stmts
         traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
         ((tc_stmts, ids), lie) <- captureConstraints $
-                                  tc_io_stmts $ \ _ ->
-                                  mapM tcLookupId names  ;
+                                  (tc_io_stmts $ \ _ ->
+                                     mapM tcLookupId names)
+                                  -- Ignore bindings for static pointers
+                                  <* checkStaticPointers ;
+
                         -- Look up the names right in the middle,
                         -- where they will all be in scope
 
@@ -1731,6 +1744,8 @@ tcRnExpr hsc_env rdr_expr
                                           captureUntouchables $
                                           tcInferRho rn_expr ;
     ((qtvs, dicts, _, _), lie_top) <- captureConstraints $
+                                      -- Ignore bindings for static pointers
+                                      checkStaticPointers >>
                                       {-# SCC "simplifyInfer" #-}
                                       simplifyInfer untch
                                                     False {- No MR for now -}
@@ -1817,8 +1832,13 @@ tcRnDeclsi hsc_env local_decls =
 
     new_ev_binds <- simplifyTop lie
     failIfErrsM
-    let TcGblEnv { tcg_type_env  = type_env,
-                   tcg_binds     = binds,
+    ((), lie2) <- captureConstraints checkStaticPointers
+    new_ev_binds2 <- {-# SCC "simplifyTop" #-}
+                     simplifyTop lie2
+
+    failIfErrsM
+    let TcGblEnv { tcg_binds     = binds,
+                   tcg_type_env  = type_env,
                    tcg_sigs      = sig_ns,
                    tcg_ev_binds  = cur_ev_binds,
                    tcg_imp_specs = imp_specs,
@@ -1826,6 +1846,7 @@ tcRnDeclsi hsc_env local_decls =
                    tcg_vects     = vects,
                    tcg_fords     = fords } = tcg_env
         all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
+                                    `unionBags` new_ev_binds2
 
     (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
         <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords
@@ -2090,3 +2111,37 @@ ppr_tydecls tycons
   where
     ppr_tycon tycon = vcat [ ppr (tyThingToIfaceDecl (ATyCon tycon)) ]
 \end{code}
+
+%************************************************************************
+%*                                                                      *
+                 checkStaticPointers
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+-- | Checks that the static forms have valid types when generalized.
+--
+-- The type @StaticPtr tau@ is valid if it is predicative, that is, tau is unqualified
+-- and monomorphic.
+--
+checkStaticPointers :: TcM ()
+checkStaticPointers = do
+    stOccsVar <- tcg_static_occs <$> getGblEnv
+    stOccs <- readTcRef stOccsVar
+    writeTcRef stOccsVar []
+    mapM_ checkStaticPointer stOccs
+  where
+    checkStaticPointer ::
+      (TcType, WantedConstraints, Untouchables, SrcSpan, [ErrCtxt]) -> TcM ()
+    checkStaticPointer (ty, lie, untch, loc, errCtx) =
+      setSrcSpan loc $ setErrCtxt errCtx $ do
+      fresh_name <- newSysName $ mkVarOccFS $ fsLit "static"
+      (_, dicts, _, _) <- simplifyInfer untch
+                                        False -- No MR
+                                        [(fresh_name, ty)]
+                                        lie
+
+      let expr_qty = mkPiTypes dicts ty
+      zty <- zonkTcType $ mkTyConApp staticPtrTyCon [ expr_qty ]
+      void $ tryM $ checkValidType StaticCtxt zty
+\end{code}
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index cd414999af..e2f032fbfe 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -97,6 +97,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                            Nothing             -> newIORef emptyNameEnv } ;
 
         dependent_files_var <- newIORef [] ;
+        static_occs_var      <- newIORef [] ;
+        static_binds_var     <- newIORef [] ;
 #ifdef GHCI
         th_topdecls_var      <- newIORef [] ;
         th_topnames_var      <- newIORef emptyNameSet ;
@@ -162,7 +164,9 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                 tcg_hpc            = False,
                 tcg_main           = Nothing,
                 tcg_safeInfer      = infer_var,
-                tcg_dependent_files = dependent_files_var
+                tcg_dependent_files = dependent_files_var,
+                tcg_static_occs    = static_occs_var,
+                tcg_static_binds   = static_binds_var
              } ;
              lcl_env = TcLclEnv {
                 tcl_errs       = errs_var,
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index e1762a8f73..bcaad8925d 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -87,6 +87,7 @@ module TcRnTypes(
 #include "HsVersions.h"
 
 import HsSyn
+import CoreSyn
 import HscTypes
 import TcEvidence
 import Type
@@ -283,6 +284,8 @@ data TcGblEnv
           --     rule
           --
           --   * Top-level variables appearing free in a TH bracket
+          --
+          --   * Top-level variables introduced by the static form
 
         tcg_th_used :: TcRef Bool,
           -- ^ @True@ <=> Template Haskell syntax used.
@@ -354,9 +357,26 @@ data TcGblEnv
         tcg_main      :: Maybe Name,         -- ^ The Name of the main
                                              -- function, if this module is
                                              -- the main module.
-        tcg_safeInfer :: TcRef Bool          -- Has the typechecker
+        tcg_safeInfer :: TcRef Bool,         -- Has the typechecker
                                              -- inferred this module
                                              -- as -XSafe (Safe Haskell)
+        tcg_static_occs :: TcRef [( TcType
+                                  , WantedConstraints
+                                  , Untouchables
+                                  , SrcSpan
+                                  , [ErrCtxt]
+                                  )],
+                -- ^ Occurrences of static forms
+                --
+                -- Each entry holds the type of the body of the static form,
+                -- the constraints the body requires, the location of the static
+                -- form and the error context to use when reporting errors.
+
+        tcg_static_binds :: IORef [(Id,CoreExpr)]
+          -- ^ Bindings resulted from floating static forms
+          --
+          -- The typechecker needs to carry this information when desugaring
+          -- splices that contain static forms.
     }
 
 -- Note [Signature parameters in TcGblEnv and DynFlags]
@@ -1875,6 +1895,7 @@ data CtOrigin
   | HoleOrigin
   | UnboundOccurrenceOf RdrName
   | ListOrigin          -- An overloaded list
+  | StaticOrigin        -- A static form
 
 ctoHerald :: SDoc
 ctoHerald = ptext (sLit "arising from")
@@ -1953,5 +1974,6 @@ 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"
 \end{code}
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index dba1be8964..cfbbb918a8 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -379,6 +379,7 @@ data UserTypeCtxt
                         -- e.g. (f e) where f has a higher-rank type
                         -- We might want to elaborate this
   | GhciCtxt            -- GHCi command :kind <type>
+  | StaticCtxt          -- Static form
 
   | ClassSCCtxt Name    -- Superclasses of a class
   | SigmaCtxt           -- Theta part of a normal for-all type
@@ -534,6 +535,7 @@ pprUserTypeCtxt InstDeclCtxt      = ptext (sLit "an instance declaration")
 pprUserTypeCtxt SpecInstCtxt      = ptext (sLit "a SPECIALISE instance pragma")
 pprUserTypeCtxt GenSigCtxt        = ptext (sLit "a type expected by the context")
 pprUserTypeCtxt GhciCtxt          = ptext (sLit "a type in a GHCi command")
+pprUserTypeCtxt StaticCtxt        = ptext (sLit "a static form")
 pprUserTypeCtxt (ClassSCCtxt c)   = ptext (sLit "the super-classes of class") <+> quotes (ppr c)
 pprUserTypeCtxt SigmaCtxt         = ptext (sLit "the context of a polymorphic type")
 pprUserTypeCtxt (DataTyCtxt tc)   = ptext (sLit "the context of the data type declaration for") <+> quotes (ppr tc)
diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs
index 8381533a28..d7e568b7e9 100644
--- a/compiler/typecheck/TcValidity.lhs
+++ b/compiler/typecheck/TcValidity.lhs
@@ -175,6 +175,7 @@ checkValidType ctxt ty
                  SpecInstCtxt   -> rank1
                  ThBrackCtxt    -> rank1
                  GhciCtxt       -> ArbitraryRank
+                 StaticCtxt     -> MustBeMonoType
                  _              -> panic "checkValidType"
                                           -- Can't happen; not used for *user* sigs