StaticPointers: Allow closed vars in the static form.

Summary:
With this patch closed variables are allowed regardless of whether
they are bound at the top level or not.

The FloatOut pass is always performed. When optimizations are
disabled, only expressions that go to the top level are floated.
Thus, the applications of the StaticPtr data constructor are always
floated.

The CoreTidy pass makes sure the floated applications appear in the
symbol table of object files. It also collects the floated bindings
and inserts them in the static pointer table.

The renamer does not check anymore if free variables appearing in the
static form are top-level. Instead, the typechecker looks at the
tct_closed flag to decide if the free variables are closed.

The linter checks that applications of StaticPtr only occur at the
top of top-level bindings after the FloatOut pass.

The field spInfoName of StaticPtrInfo has been removed. It used to
contain the name of the top-level binding that contains the StaticPtr
application. However, this information is no longer available when the
StaticPtr is constructed, as the binding name is determined now by the
FloatOut pass.

Test Plan: ./validate

Reviewers: goldfire, simonpj, austin, hvr, bgamari

Reviewed By: simonpj

Subscribers: thomie, mpickering, mboes

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

GHC Trac Issues: #11656

30 files changed, 445 insertions, 276 deletions

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 26383af..5ce4cee 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -66,8 +66,10 @@ import Control.Monad
 import qualified Control.Monad.Fail as MonadFail
 #endif
 import MonadUtils
+import Data.Function (fix)
 import Data.Maybe
 import Pair
+import qualified GHC.LanguageExtensions as LangExt
 
 {-
 Note [GHC Formalism]
@@ -370,7 +372,8 @@ lintCoreBindings dflags pass local_in_scope binds
        ; mapM lint_bind binds }
   where
     flags = LF { lf_check_global_ids = check_globals
-               , lf_check_inline_loop_breakers = check_lbs }
+               , lf_check_inline_loop_breakers = check_lbs
+               , lf_check_static_ptrs = check_static_ptrs }
 
     -- See Note [Checking for global Ids]
     check_globals = case pass of
@@ -384,6 +387,14 @@ lintCoreBindings dflags pass local_in_scope binds
                       CoreDesugarOpt -> False
                       _              -> True
 
+    -- See Note [Checking StaticPtrs]
+    check_static_ptrs = xopt LangExt.StaticPointers dflags &&
+                        case pass of
+                          CoreDoFloatOutwards _ -> True
+                          CoreTidy              -> True
+                          CorePrep              -> True
+                          _                     -> False
+
     binders = bindersOfBinds binds
     (_, dups) = removeDups compare binders
 
@@ -460,7 +471,7 @@ lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
 lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
   = addLoc (RhsOf binder) $
          -- Check the rhs
-    do { ty <- lintCoreExpr rhs
+    do { ty <- lintRhs rhs
        ; lintBinder binder -- Check match to RHS type
        ; binder_ty <- applySubstTy (idType binder)
        ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty)
@@ -530,6 +541,32 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
     lintBinder var | isId var  = lintIdBndr var $ \_ -> (return ())
                    | otherwise = return ()
 
+-- | Checks the RHS of top-level bindings. It only differs from 'lintCoreExpr'
+-- in that it doesn't reject applications of the data constructor @StaticPtr@
+-- when they appear at the top level.
+--
+-- See Note [Checking StaticPtrs].
+lintRhs :: CoreExpr -> LintM OutType
+-- Allow applications of the data constructor @StaticPtr@ at the top
+-- but produce errors otherwise.
+lintRhs rhs
+    | (binders0, rhs') <- collectTyBinders rhs
+    , (fun@(Var b), args) <- collectArgs rhs'
+    , Just con <- isDataConId_maybe b
+    , dataConName con == staticPtrDataConName
+    , length args == 5
+    = flip fix binders0 $ \loopBinders binders -> case binders of
+        -- imitate @lintCoreExpr (Lam ...)@
+        var : vars -> addLoc (LambdaBodyOf var) $ lintBinder var $ \var' -> do
+          body_ty <- loopBinders vars
+          return $ mkPiType var' body_ty
+        -- imitate @lintCoreExpr (App ...)@
+        [] -> do
+          fun_ty <- lintCoreExpr fun
+          addLoc (AnExpr rhs') $ foldM lintCoreArg fun_ty args
+-- Rejects applications of the data constructor @StaticPtr@ if it finds any.
+lintRhs rhs = lintCoreExpr rhs
+
 lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
 lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
   | isStableSource src
@@ -644,9 +681,21 @@ lintCoreExpr (Let (Rec pairs) body)
     (_, dups) = removeDups compare bndrs
 
 lintCoreExpr e@(App _ _)
-    = do { fun_ty <- lintCoreExpr fun
-         ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args }
+    = do lf <- getLintFlags
+         -- Check for a nested occurrence of the StaticPtr constructor.
+         -- See Note [Checking StaticPtrs].
+         case fun of
+           Var b | lf_check_static_ptrs lf
+                 , Just con <- isDataConId_maybe b
+                 , dataConName con == staticPtrDataConName
+                 -> do
+              failWithL $ text "Found StaticPtr nested in an expression: " <+>
+                          ppr e
+           _     -> go
   where
+    go = do { fun_ty <- lintCoreExpr fun
+            ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args }
+
     (fun, args) = collectArgs e
 
 lintCoreExpr (Lam var expr)
@@ -1563,11 +1612,14 @@ data LintEnv
 data LintFlags
   = LF { lf_check_global_ids           :: Bool -- See Note [Checking for global Ids]
        , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers]
+       , lf_check_static_ptrs          :: Bool -- See Note [Checking StaticPtrs]
     }
 
 defaultLintFlags :: LintFlags
 defaultLintFlags = LF { lf_check_global_ids = False
-                      , lf_check_inline_loop_breakers = True }
+                      , lf_check_inline_loop_breakers = True
+                      , lf_check_static_ptrs = False
+                      }
 
 newtype LintM a =
    LintM { unLintM ::
@@ -1582,6 +1634,13 @@ type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)
 Before CoreTidy, all locally-bound Ids must be LocalIds, even
 top-level ones. See Note [Exported LocalIds] and Trac #9857.
 
+Note [Checking StaticPtrs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Every occurrence of the data constructor @StaticPtr@ should be moved to the top
+level by the FloatOut pass. The linter is checking that no occurrence is left
+nested within an expression.
+
 Note [Type substitution]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 Why do we need a type substitution?  Consider
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index 7479dcd..432f242 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -31,7 +31,7 @@ module CoreSyn (
 
         -- ** Simple 'Expr' access functions and predicates
         bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
-        collectBinders, collectTyAndValBinders,
+        collectBinders, collectTyBinders, collectTyAndValBinders,
         collectArgs, collectArgsTicks, flattenBinds,
 
         exprToType, exprToCoercion_maybe,
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 139aa0e..b082a02 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -589,7 +589,7 @@ addTickHsExpr (ExplicitPArr ty es) =
                 (return ty)
                 (mapM (addTickLHsExpr) es)
 
-addTickHsExpr (HsStatic e) = HsStatic <$> addTickLHsExpr e
+addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
 
 addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })
   = do { rec_binds' <- addTickHsRecordBinds rec_binds
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index db4c867..34df427 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -60,7 +60,6 @@ import Coverage
 import Util
 import MonadUtils
 import OrdList
-import StaticPtrTable
 import UniqFM
 import ListSetOps
 import Fingerprint
@@ -312,20 +311,13 @@ 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
-                                              `appendStubC` spt_init) }
+                                   , ds_fords `appendStubC` hpc_init) }
 
         ; case mb_res of {
            Nothing -> return (msgs, Nothing) ;
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index c037bb1..c33b867 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -57,8 +57,7 @@ import Outputable
 import FastString
 import PatSyn
 
-import IfaceEnv
-import Data.IORef       ( atomicModifyIORef', modifyIORef )
+import Data.IORef       ( atomicModifyIORef' )
 
 import Control.Monad
 import GHC.Fingerprint
@@ -412,30 +411,27 @@ dsExpr (PArrSeq _ _)
     -- shouldn't have let it through
 
 {-
-\noindent
-\underline{\bf Static Pointers}
-               ~~~~~~~~~~~~~~~
-\begin{verbatim}
+Static Pointers
+~~~~~~~~~~~~~~~
+
     g = ... static f ...
 ==>
-    sptEntry:N = StaticPtr
-        (fingerprintString "pkgKey:module.sptEntry:N")
-        (StaticPtrInfo "current pkg key" "current module" "sptEntry:0")
-        f
-    g = ... sptEntry:N
-\end{verbatim}
+    g = ... StaticPtr
+              w0 w1
+              (StaticPtrInfo "current pkg key" "current module" "N")
+              f
+        ...
+
+Where we obtain w0 and w1 from
+
+   Fingerprint w0 w1 = fingerprintString "pkgKey:module:N"
 -}
 
-dsExpr (HsStatic expr@(L loc _)) = do
+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
@@ -447,43 +443,51 @@ dsExpr (HsStatic expr@(L loc _)) = do
                      [ Type intTy              , Type intTy
                      , mkIntExprInt dflags line, mkIntExprInt dflags col
                      ]
+    this_mod <- getModule
     info <- mkConApp staticPtrInfoDataCon <$>
             (++[srcLoc]) <$>
             mapM mkStringExprFS
-                 [ unitIdFS $ moduleUnitId $ nameModule n'
-                 , moduleNameFS $ moduleName $ nameModule n'
-                 , occNameFS    $ nameOccName n'
+                 [ unitIdFS $ moduleUnitId this_mod
+                 , moduleNameFS $ moduleName this_mod
                  ]
-    let tvars = tyCoVarsOfTypeWellScoped ty
-        speTy = ASSERT( all isTyVar tvars )  -- ty is top-level, so this is OK
-                mkInvForAllTys tvars $ mkTyConApp staticPtrTyCon [ty]
-        speId = mkExportedVanillaId 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) (mkTyVarTys tvars)
+    Fingerprint w0 w1 <- mkStaticPtrFingerprint this_mod
+    putSrcSpanDs loc $ return $
+      mkConApp staticPtrDataCon [ Type ty
+                                , mkWord64LitWordRep dflags w0
+                                , mkWord64LitWordRep dflags w1
+                                , info
+                                , expr_ds
+                                ]
 
   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
-        [ unitIdFS $ moduleUnitId $ nameModule n
+    mkStaticPtrFingerprint :: Module -> DsM Fingerprint
+    mkStaticPtrFingerprint this_mod = do
+      n <- mkGenPerModuleNum this_mod
+      return $ fingerprintString $ unpackFS $ concatFS
+        [ unitIdFS $ moduleUnitId this_mod
+        , fsLit ":"
+        , moduleNameFS $ moduleName this_mod
         , fsLit ":"
-        , moduleNameFS (moduleName $ nameModule n)
-        , fsLit "."
-        , occNameFS $ occName n
+        , mkFastString $ show n
         ]
 
+    mkGenPerModuleNum :: Module -> DsM Int
+    mkGenPerModuleNum this_mod = do
+      dflags <- getDynFlags
+      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 this_mod
+         in (extendModuleEnv mod_env this_mod (num + 1), num)
+      return wrapperNum
+
 {-
 \noindent
 \underline{\bf Record construction and update}
@@ -1011,33 +1015,3 @@ badMonadBind rhs elt_ty
          , hang (text "Suppress this warning by saying")
               2 (quotes $ text "_ <-" <+> ppr rhs)
          ]
-
-{-
-************************************************************************
-*                                                                      *
-\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
-    mod  <- getModule
-    occ  <- mkWrapperName "sptEntry"
-    newGlobalBinder 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
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 3e224a3..b00717e 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1182,7 +1182,7 @@ repE (ArithSeq _ _ aseq) =
                              repFromThenTo ds1 ds2 ds3
 
 repE (HsSpliceE splice)    = repSplice splice
-repE (HsStatic e)          = repLE e >>= rep2 staticEName . (:[]) . unC
+repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC
 repE (HsUnboundVar uv)     = do
                                occ   <- occNameLit (unboundVarOcc uv)
                                sname <- repNameS occ
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index 79ca265..de14107 100644
--- a/compiler/deSugar/DsMonad.hs
+++ b/compiler/deSugar/DsMonad.hs
@@ -22,7 +22,7 @@ module DsMonad (
         mkPrintUnqualifiedDs,
         newUnique,
         UniqSupply, newUniqueSupply,
-        getGhcModeDs, dsGetFamInstEnvs, dsGetStaticBindsVar,
+        getGhcModeDs, dsGetFamInstEnvs,
         dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
 
         PArrBuiltin(..),
@@ -74,7 +74,6 @@ import ErrUtils
 import FastString
 import Maybes
 import Var (EvVar)
-import GHC.Fingerprint
 import qualified GHC.LanguageExtensions as LangExt
 
 import Data.IORef
@@ -148,12 +147,10 @@ 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 []
         ; pm_iter_var      <- newIORef 0
         ; let dflags                   = hsc_dflags hsc_env
               (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env
                                                   fam_inst_env msg_var
-                                                  static_binds_var
                                                   pm_iter_var
 
         ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
@@ -229,13 +226,12 @@ initDsTc thing_inside
         ; tcg_env  <- getGblEnv
         ; msg_var  <- getErrsVar
         ; dflags   <- getDynFlags
-        ; static_binds_var <- liftIO $ newIORef []
         ; pm_iter_var      <- liftIO $ newIORef 0
         ; 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 pm_iter_var
+                                  msg_var pm_iter_var
         ; setEnvs ds_envs thing_inside
         }
 
@@ -263,9 +259,8 @@ initTcDsForSolver thing_inside
          thing_inside }
 
 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-         -> IORef Messages -> IORef [(Fingerprint, (Id, CoreExpr))]
-         -> IORef Int -> (DsGblEnv, DsLclEnv)
-mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var pmvar
+         -> IORef Messages -> IORef Int -> (DsGblEnv, DsLclEnv)
+mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
   = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
         if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
         real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
@@ -276,7 +271,6 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var pmvar
                            , 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 { dsl_meta    = emptyNameEnv
                            , dsl_loc     = real_span
@@ -517,10 +511,6 @@ dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 dsExtendMetaEnv menv thing_inside
   = updLclEnv (\env -> env { dsl_meta = dsl_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
deleted file mode 100644
index d1e8e05..0000000
--- a/compiler/deSugar/StaticPtrTable.hs
+++ /dev/null
@@ -1,97 +0,0 @@
--- | 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 the constants are fingerprints produced from the static forms.
---
--- There is also a finalization function for the time when the module is
--- unloaded.
---
--- > static void hs_hpc_fini_Main(void) __attribute__((destructor));
--- > static void hs_hpc_fini_Main(void) {
--- >
--- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
--- >   hs_spt_remove(k0);
--- >
--- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
--- >   hs_spt_remove(k1);
--- >
--- > }
---
-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
-        ]
-    , text "static void hs_spt_fini_" <> ppr this_mod
-           <> text "(void) __attribute__((destructor));"
-    , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"
-    , braces $ vcat $
-        [  text "StgWord64 k" <> int i <> text "[2] = "
-           <> pprFingerprint fp <> semi
-        $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
-        | (i, (fp, _)) <- 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"
-                 ]
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 520eb13..9274725 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -797,7 +797,7 @@ cvtl e = wrapL (cvt e)
                                   <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
                                            flds
                               ; return $ mkRdrRecordUpd e' flds' }
-    cvt (StaticE e)      = fmap HsStatic $ cvtl e
+    cvt (StaticE e)      = fmap (HsStatic placeHolderNames) $ cvtl e
     cvt (UnboundVarE s)  = do { s' <- vName s; return $ HsVar (noLoc s') }
 
 {- Note [Dropping constructors]
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index f839589..ffbd23c 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -385,7 +385,7 @@ variables.  The action happens in TcBinds.mkExport.
 Note [Bind free vars]
 ~~~~~~~~~~~~~~~~~~~~~
 The bind_fvs field of FunBind and PatBind records the free variables
-of the definition.  It is used for two purposes
+of the definition.  It is used for the following purposes
 
 a) Dependency analysis prior to type checking
     (see TcBinds.tc_group)
@@ -393,6 +393,10 @@ a) Dependency analysis prior to type checking
 b) Deciding whether we can do generalisation of the binding
     (see TcBinds.decideGeneralisationPlan)
 
+c) Deciding whether the binding can be used in static forms
+    (see TcExpr.checkClosedInStaticForm for the HsStatic case and
+     TcBinds.isClosedBndrGroup).
+
 Specifically,
 
   * bind_fvs includes all free vars that are defined in this module
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index b6c5bdd..a6aaa6c 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -30,6 +30,7 @@ import CoreSyn
 import Var
 import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) )
 import Name
+import NameSet
 import RdrName  ( GlobalRdrEnv )
 import BasicTypes
 import ConLike
@@ -562,7 +563,8 @@ data HsExpr id
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic',
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsStatic    (LHsExpr id)
+  | HsStatic (PostRn id NameSet) -- Free variables of the body
+             (LHsExpr id)        -- Body
 
   ---------------------------------------
   -- The following are commands, not expressions proper
@@ -920,7 +922,7 @@ ppr_expr (HsTcBracketOut e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
 ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
   = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]
 
-ppr_expr (HsStatic e)
+ppr_expr (HsStatic _ e)
   = hsep [text "static", pprParendLExpr e]
 
 ppr_expr (HsTick tickish exp)
diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs
new file mode 100644
index 0000000..c13bcd8
--- /dev/null
+++ b/compiler/main/StaticPtrTable.hs
@@ -0,0 +1,125 @@
+-- | 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_r2wb_closure;
+-- >   hs_spt_insert(k0, &Main_r2wb_closure);
+-- >
+-- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
+-- >   extern StgPtr Main_r2wc_closure;
+-- >   hs_spt_insert(k1, &Main_r2wc_closure);
+-- >
+-- > }
+--
+-- where the constants are fingerprints produced from the static forms.
+--
+-- The linker must find the definitions matching the @extern StgPtr <name>@
+-- declarations. For this to work, the identifiers of static pointers need to be
+-- exported. This is done in TidyPgm.chooseExternalIds.
+--
+-- There is also a finalization function for the time when the module is
+-- unloaded.
+--
+-- > static void hs_hpc_fini_Main(void) __attribute__((destructor));
+-- > static void hs_hpc_fini_Main(void) {
+-- >
+-- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
+-- >   hs_spt_remove(k0);
+-- >
+-- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
+-- >   hs_spt_remove(k1);
+-- >
+-- > }
+--
+
+{-# LANGUAGE ViewPatterns #-}
+module StaticPtrTable (sptModuleInitCode) where
+
+import CLabel
+import CoreSyn
+import DataCon
+import Id
+import Literal
+import Module
+import Outputable
+import PrelNames
+
+import Data.Maybe
+import GHC.Fingerprint
+
+-- | @sptModuleInitCode module binds@ is a C stub to insert the static entries
+-- found in @binds@ of @module@ into the static pointer table.
+--
+-- A bind is considered a static entry if it is an application of the
+-- data constructor @StaticPtr@.
+--
+sptModuleInitCode :: Module -> CoreProgram -> SDoc
+sptModuleInitCode this_mod binds =
+    sptInitCode $ catMaybes
+                $ map (\(b, e) -> ((,) b) <$> staticPtrFp e)
+                $ flattenBinds binds
+  where
+    staticPtrFp :: CoreExpr -> Maybe Fingerprint
+    staticPtrFp (collectTyBinders -> (_, e))
+      | (Var v, _ : Lit lit0 : Lit lit1 : _) <- collectArgs e
+      , Just con <- isDataConId_maybe v
+      , dataConName con == staticPtrDataConName
+      , Just w0 <- fromPlatformWord64Rep lit0
+      , Just w1 <- fromPlatformWord64Rep lit1
+      = Just $ Fingerprint (fromInteger w0) (fromInteger w1)
+    staticPtrFp _ = Nothing
+
+    fromPlatformWord64Rep (MachWord w)   = Just w
+    fromPlatformWord64Rep (MachWord64 w) = Just w
+    fromPlatformWord64Rep _              = Nothing
+
+    sptInitCode :: [(Id, Fingerprint)] -> SDoc
+    sptInitCode [] = Outputable.empty
+    sptInitCode 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, (n, fp)) <- zip [0..] entries
+          ]
+      , text "static void hs_spt_fini_" <> ppr this_mod
+             <> text "(void) __attribute__((destructor));"
+      , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"
+      , braces $ vcat $
+          [  text "StgWord64 k" <> int i <> text "[2] = "
+             <> pprFingerprint fp <> semi
+          $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
+          | (i, (_, fp)) <- zip [0..] entries
+          ]
+      ]
+
+    pprFingerprint :: Fingerprint -> SDoc
+    pprFingerprint (Fingerprint w1 w2) =
+      braces $ hcat $ punctuate comma
+                 [ integer (fromIntegral w1) <> text "ULL"
+                 , integer (fromIntegral w2) <> text "ULL"
+                 ]
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index 4ecd615..945e3f8 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -4,7 +4,7 @@
 \section{Tidying up Core}
 -}
 
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, ViewPatterns #-}
 
 module TidyPgm (
        mkBootModDetailsTc, tidyProgram, globaliseAndTidyId
@@ -24,10 +24,12 @@ import CoreUtils        (rhsIsStatic)
 import CoreStats        (coreBindsStats, CoreStats(..))
 import CoreLint
 import Literal
+import PrelNames
 import Rules
 import PatSyn
 import ConLike
 import CoreArity        ( exprArity, exprBotStrictness_maybe )
+import StaticPtrTable
 import VarEnv
 import VarSet
 import Var
@@ -233,7 +235,8 @@ First we figure out which Ids are "external" Ids.  An
 "external" Id is one that is visible from outside the compilation
 unit.  These are
   a) the user exported ones
-  b) ones mentioned in the unfoldings, workers,
+  b) the ones bound to static forms
+  c) ones mentioned in the unfoldings, workers,
      rules of externally-visible ones ,
      or vectorised versions of externally-visible ones
 
@@ -405,7 +408,8 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
         ; return (CgGuts { cg_module   = mod,
                            cg_tycons   = alg_tycons,
                            cg_binds    = all_tidy_binds,
-                           cg_foreign  = foreign_stubs,
+                           cg_foreign  = foreign_stubs `appendStubC`
+                                           sptModuleInitCode mod all_tidy_binds,
                            cg_dep_pkgs = map fst $ dep_pkgs deps,
                            cg_hpc_info = hpc_info,
                            cg_modBreaks = modBreaks },
@@ -635,17 +639,29 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
   -- bindings, which are ordered non-deterministically.
   init_work_list = zip init_ext_ids init_ext_ids
   init_ext_ids   = sortBy (compare `on` getOccName) $
-                   filter is_external binders
+                   map fst $ filter is_external flatten_binds
 
   -- An Id should be external if either (a) it is exported,
   -- (b) it appears in the RHS of a local rule for an imported Id, or
-  -- (c) it is the vectorised version of an imported Id
+  -- (c) it is the vectorised version of an imported Id, or
+  -- (d) it is a static pointer (see notes in StaticPtrTable.hs).
   -- See Note [Which rules to expose]
-  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars || id `elemVarSet` vect_var_vs
+  is_external (id, e) = isExportedId id || id `elemVarSet` rule_rhs_vars
+                      || id `elemVarSet` vect_var_vs
+                      || isStaticPtrApp e
+
+  isStaticPtrApp :: CoreExpr -> Bool
+  isStaticPtrApp (collectTyBinders -> (_, e))
+      | (Var v, _) <- collectArgs e
+      , Just con <- isDataConId_maybe v
+      =  dataConName con == staticPtrDataConName
+  isStaticPtrApp _ = False
+
   rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules
   vect_var_vs    = mkVarSet [var_v | (var, var_v) <- nameEnvElts vect_vars, isGlobalId var]
 
-  binders          = bindersOfBinds binds
+  flatten_binds    = flattenBinds binds
+  binders          = map fst flatten_binds
   implicit_binders = bindersOfBinds implicit_binds
   binder_set       = mkVarSet binders
 
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 4975661..998ef6c 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2244,7 +2244,7 @@ fexp    :: { LHsExpr RdrName }
         : fexp aexp                  { sLL $1 $> $ HsApp $1 $2 }
         | fexp TYPEAPP atype         {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3))
                                             [mj AnnAt $2] }
-        | 'static' aexp              {% ams (sLL $1 $> $ HsStatic $2)
+        | 'static' aexp              {% ams (sLL $1 $> $ HsStatic placeHolderNames $2)
                                             [mj AnnStatic $1] }
         | aexp                       { $1 }
 
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 2ee2911..af58135 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -349,7 +349,7 @@ value bindings. This is done by checking that the name is external or
 wired-in. See the Notes about the NameSorts in Name.hs.
 -}
 
-rnExpr e@(HsStatic expr) = do
+rnExpr e@(HsStatic _ expr) = do
     target <- fmap hscTarget getDynFlags
     case target of
       -- SPT entries are expected to exist in object code so far, and this is
@@ -362,28 +362,14 @@ 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
-                             (\n -> not (isTopLevelName n || isUnboundName n))
-                             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)
+      _ -> return ()
+    mod <- getModule
+    let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr
+    return (HsStatic fvExpr' expr', fvExpr)
 
 {-
 ************************************************************************
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index de22e65..fa43312 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -210,10 +210,12 @@ data FloatOutSwitches = FloatOutSwitches {
 
   floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,
                                    --            even if they do not escape a lambda
-  floatOutOverSatApps :: Bool      -- ^ True <=> float out over-saturated applications
-                                   --            based on arity information.
-                                   -- See Note [Floating over-saturated applications]
-                                   -- in SetLevels
+  floatOutOverSatApps :: Bool,
+                             -- ^ True <=> float out over-saturated applications
+                             --            based on arity information.
+                             -- See Note [Floating over-saturated applications]
+                             -- in SetLevels
+  floatToTopLevelOnly :: Bool      -- ^ Allow floating to the top level only.
   }
 instance Outputable FloatOutSwitches where
     ppr = pprFloatOutSwitches
diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
index f2d82ac..86442ab 100644
--- a/compiler/simplCore/SetLevels.hs
+++ b/compiler/simplCore/SetLevels.hs
@@ -377,6 +377,7 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts
   | [(con@(DataAlt {}), bs, body)] <- alts
   , exprOkForSpeculation scrut'   -- See Note [Check the output scrutinee for okForSpec]
   , not (isTopLvl dest_lvl)       -- Can't have top-level cases
+  , not (floatTopLvlOnly env)     -- Can float anywhere
   =     -- See Note [Floating cases]
         -- Always float the case if possible
         -- Unlike lets we don't insist that it escapes a value lambda
@@ -475,7 +476,9 @@ lvlMFE True env e@(_, AnnCase {})
   = lvlExpr env e     -- Don't share cases
 
 lvlMFE strict_ctxt env ann_expr
-  |  isUnliftedType (exprType expr)
+  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)
+         -- Only floating to the top level is allowed.
+  || isUnliftedType (exprType expr)
          -- Can't let-bind it; see Note [Unlifted MFEs]
          -- This includes coercions, which we don't want to float anyway
          -- NB: no need to substitute cos isUnliftedType doesn't change
@@ -730,7 +733,9 @@ lvlBind env (AnnNonRec bndr rhs)
     is_bot     = exprIsBottom (deAnnotate rhs)
 
 lvlBind env (AnnRec pairs)
-  | not (profitableFloat env dest_lvl)
+  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)
+         -- Only floating to the top level is allowed.
+  || not (profitableFloat env dest_lvl)
   = do { let bind_lvl = incMinorLvl (le_ctxt_lvl env)
              (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs
        ; rhss' <- mapM (lvlExpr env') rhss
@@ -979,6 +984,9 @@ floatConsts le = floatOutConstants (le_switches le)
 floatOverSat :: LevelEnv -> Bool
 floatOverSat le = floatOutOverSatApps (le_switches le)
 
+floatTopLvlOnly :: LevelEnv -> Bool
+floatTopLvlOnly le = floatToTopLevelOnly (le_switches le)
+
 setCtxtLvl :: LevelEnv -> Level -> LevelEnv
 setCtxtLvl env lvl = env { le_ctxt_lvl = lvl }
 
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index 1ff0cee..654fd52 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -53,6 +53,7 @@ import Maybes
 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
 import Outputable
 import Control.Monad
+import qualified GHC.LanguageExtensions as LangExt
 
 #ifdef GHCI
 import DynamicLoading   ( loadPlugins )
@@ -128,6 +129,7 @@ getCoreToDo dflags
     rules_on      = gopt Opt_EnableRewriteRules           dflags
     eta_expand_on = gopt Opt_DoLambdaEtaExpansion         dflags
     ww_on         = gopt Opt_WorkerWrapper                dflags
+    static_ptrs   = xopt LangExt.StaticPointers           dflags
 
     maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
 
@@ -201,8 +203,15 @@ getCoreToDo dflags
 
     core_todo =
      if opt_level == 0 then
-       [ vectorisation
-       , CoreDoSimplify max_iter
+       [ vectorisation,
+         -- Static forms are moved to the top level with the FloatOut pass.
+         -- See Note [Grand plan for static forms].
+         runWhen static_ptrs $ CoreDoFloatOutwards FloatOutSwitches {
+                                 floatOutLambdas   = Just 0,
+                                 floatOutConstants = True,
+                                 floatOutOverSatApps = False,
+                                 floatToTopLevelOnly = True },
+         CoreDoSimplify max_iter
              (base_mode { sm_phase = Phase 0
                         , sm_names = ["Non-opt simplification"] })
        ]
@@ -230,7 +239,8 @@ getCoreToDo dflags
            CoreDoFloatOutwards FloatOutSwitches {
                                  floatOutLambdas   = Just 0,
                                  floatOutConstants = True,
-                                 floatOutOverSatApps = False },
+                                 floatOutOverSatApps = False,
+                                 floatToTopLevelOnly = False },
                 -- Was: gentleFloatOutSwitches
                 --
                 -- I have no idea why, but not floating constants to
@@ -281,7 +291,8 @@ getCoreToDo dflags
            CoreDoFloatOutwards FloatOutSwitches {
                                  floatOutLambdas     = floatLamArgs dflags,
                                  floatOutConstants   = True,
-                                 floatOutOverSatApps = True },
+                                 floatOutOverSatApps = True,
+                                 floatToTopLevelOnly = False },
                 -- nofib/spectral/hartel/wang doubles in speed if you
                 -- do full laziness late in the day.  It only happens
                 -- after fusion and other stuff, so the early pass doesn't
@@ -977,3 +988,29 @@ transferIdInfo exported_id local_id
                                (ruleInfo local_info)
         -- Remember to set the function-name field of the
         -- rules as we transfer them from one function to another
+
+
+-- Note [Grand plan for static forms]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Static forms go through the compilation phases as follows:
+--
+-- The renamer looks for out-of-scope names in the body of the static form.
+-- If all names are in scope, the free variables of the body are stored in AST
+-- at the location of the static form.
+--
+-- The typechecker verifies that all free variables occurring in the static form
+-- are closed (see Note [Bindings with closed types] in TcRnTypes).
+--
+-- The desugarer replaces the static form with an application of the data
+-- constructor 'StaticPtr' (defined in module GHC.StaticPtr of base).
+--
+-- The simplifier runs the FloatOut pass which moves the applications of
+-- 'StaticPtr' to the top level. Thus the FloatOut pass is always executed,
+-- event when optimizations are disabled.
+--
+-- The CoreTidy pass produces a C function which inserts all the floated
+-- 'StaticPtr' in the static pointer table (See StaticPtrTable.hs).
+-- This pass also exports the Ids of floated 'StaticPtr's so they can be linked
+-- with the C function.
+--
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 79fd250..11ec9ab 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -566,7 +566,7 @@ tcExpr (HsProc pat cmd) res_ty
         ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
 
 -- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
-tcExpr (HsStatic expr) res_ty
+tcExpr (HsStatic fvs expr) res_ty
   = do  { res_ty          <- expTypeToType res_ty
         ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty
         ; (expr', lie)    <- captureConstraints $
@@ -574,6 +574,9 @@ tcExpr (HsStatic expr) res_ty
                              2 (ppr expr)
                        ) $
             tcPolyExprNC expr expr_ty
+        -- Check that the free variables of the static form are closed.
+        ; mapM_ checkClosedInStaticForm fvs
+
         -- 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
@@ -591,7 +594,7 @@ tcExpr (HsStatic expr) res_ty
         ; let wrap = mkWpTyApps [expr_ty]
         ; loc <- getSrcSpanM
         ; return $ mkHsWrapCo co $ HsApp (L loc $ mkHsWrap wrap fromStaticPtr)
-                                         (L loc (HsStatic expr'))
+                                         (L loc (HsStatic fvs expr'))
         }
 
 {-
@@ -2478,3 +2481,20 @@ badOverloadedUpdate = text "Record update is ambiguous, and requires a type sign
 fieldNotInType :: RecSelParent -> RdrName -> SDoc
 fieldNotInType p rdr
   = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Static Pointers}
+*                                                                      *
+************************************************************************
+-}
+
+checkClosedInStaticForm :: Name -> TcM ()
+checkClosedInStaticForm name = do
+    thing <- tcLookup name
+    case thing of
+      ATcId { tct_closed = NotTopLevel } ->
+         addErrTc $ quotes (ppr name) <+>
+                    text "is used in a static form but it is not closed."
+      _ -> return ()
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index c4c4b65..36aeb50 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -793,8 +793,8 @@ zonkExpr env (HsProc pat body)
         ; return (HsProc new_pat new_body) }
 
 -- StaticPointers extension
-zonkExpr env (HsStatic expr)
-  = HsStatic <$> zonkLExpr env expr
+zonkExpr env (HsStatic fvs expr)
+  = HsStatic fvs <$> zonkLExpr env expr
 
 zonkExpr env (HsWrap co_fn expr)
   = do (env1, new_co_fn) <- zonkCoFn env co_fn
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 2172cd8..bce7002 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -170,7 +170,6 @@ import DynFlags
 import Outputable
 import ListSetOps
 import FastString
-import GHC.Fingerprint
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad (ap, liftM, msum)
@@ -328,8 +327,6 @@ 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
diff --git a/docs/users_guide/8.0.2-notes.rst b/docs/users_guide/8.0.2-notes.rst
new file mode 100644
index 0000000..8466b49
--- /dev/null
+++ b/docs/users_guide/8.0.2-notes.rst
@@ -0,0 +1,23 @@
+.. _release-8-0-2:
+
+Release notes for version 8.0.2
+===============================
+
+TODO FIXME
+
+Highlights
+----------
+
+TODO FIXME.
+
+Full details
+------------
+
+Language
+~~~~~~~~
+
+-  TODO FIXME.
+
+-  :ghc-flag:`-XStaticPointers` now allows the body of the ``static`` form to
+   refer to closed local bindings. For instance, this is now permitted:
+   ``f = static x where x = 'a'``.
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index 863c054..3f30dc5 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -11620,9 +11620,11 @@ 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
 :base-ref:`deRefStaticPtr <GHC-StaticPtr.html#v%3AdeRefStaticPtr>`.
 
-The body ``e`` of a ``static e`` expression must be a closed expression.
-That is, there can be no free variables occurring in ``e``, i.e. lambda-
-or let-bound variables bound locally in the context of the expression.
+The body ``e`` of a ``static e`` expression must be a closed expression. Where
+we say an expression is *closed* when all of its free (type) variables are
+closed. And a variable is *closed* if it is let-bound to a *closed* expression
+and its type is *closed* as well. And a type is *closed* if it has no free
+variables.
 
 All of the following are permissible: ::
 
@@ -11634,11 +11636,14 @@ All of the following are permissible: ::
     ref3 = static (inc 1)
     ref4 = static ((\x -> x + 1) (1 :: Int))
     ref5 y = static (let x = 1 in x)
+    ref6 y = let x = 1 in static x
 
 While the following definitions are rejected: ::
 
-    ref6 = let x = 1 in static x
-    ref7 y = static (let x = 1 in y)
+    ref7 y = let x = y in static x    -- x is not closed
+    ref8 y = static (let x = 1 in y)  -- y is not let-bound
+    ref8 (y :: a) = let x = undefined :: a
+                     in static x      -- x has a non-closed type
 
 .. _typechecking-static-pointers:
 
diff --git a/libraries/base/GHC/StaticPtr.hs b/libraries/base/GHC/StaticPtr.hs
index 3d5807a..1f14520 100644
--- a/libraries/base/GHC/StaticPtr.hs
+++ b/libraries/base/GHC/StaticPtr.hs
@@ -1,6 +1,7 @@
+{-# LANGUAGE CPP                       #-}
+{-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE MagicHash                 #-}
 {-# LANGUAGE UnboxedTuples             #-}
-{-# LANGUAGE ExistentialQuantification #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.StaticPtr
@@ -47,14 +48,24 @@ import Foreign.Ptr         (castPtr)
 import GHC.Exts            (addrToAny#)
 import GHC.Ptr             (Ptr(..), nullPtr)
 import GHC.Fingerprint     (Fingerprint(..))
+import GHC.Prim
+import GHC.Word            (Word64(..))
 
 
--- | A reference to a value of type 'a'.
-data StaticPtr a = StaticPtr StaticKey StaticPtrInfo a
+#include "MachDeps.h"
 
+-- | A reference to a value of type 'a'.
+#if WORD_SIZE_IN_BITS < 64
+data StaticPtr a = StaticPtr Word64# Word64# -- The flattened Fingerprint is
+                                             -- convenient in the compiler.
+                             StaticPtrInfo a
+#else
+data StaticPtr a = StaticPtr Word# Word#
+                             StaticPtrInfo a
+#endif
 -- | Dereferences a static pointer.
 deRefStaticPtr :: StaticPtr a -> a
-deRefStaticPtr (StaticPtr _ _ v) = v
+deRefStaticPtr (StaticPtr _ _ _ v) = v
 
 -- | A key for `StaticPtrs` that can be serialized and used with
 -- 'unsafeLookupStaticPtr'.
@@ -62,7 +73,7 @@ type StaticKey = Fingerprint
 
 -- | The 'StaticKey' that can be used to look up the given 'StaticPtr'.
 staticKey :: StaticPtr a -> StaticKey
-staticKey (StaticPtr k _ _) = k
+staticKey (StaticPtr w0 w1 _ _) = Fingerprint (W64# w0) (W64# w1)
 
 -- | Looks up a 'StaticPtr' by its 'StaticKey'.
 --
@@ -94,9 +105,6 @@ data StaticPtrInfo = StaticPtrInfo
       spInfoUnitId  :: 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.
     , spInfoSrcLoc     :: (Int, Int)
@@ -105,7 +113,7 @@ data StaticPtrInfo = StaticPtrInfo
 
 -- | 'StaticPtrInfo' of the given 'StaticPtr'.
 staticPtrInfo :: StaticPtr a -> StaticPtrInfo
-staticPtrInfo (StaticPtr _ n _) = n
+staticPtrInfo (StaticPtr _ _ n _) = n
 
 -- | A list of all known keys.
 staticPtrKeys :: IO [StaticKey]
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index dd386ed..4b40db7 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -157,6 +157,9 @@
 
   * `CallStack` now has an `IsList` instance
 
+  * The field `spInfoName` of `GHC.StaticPtr.StaticPtrInfo` has been removed.
+    The value is no longer available when constructing the `StaticPtr`.
+
 ### Generalizations
 
   * Generalize `Debug.Trace.{traceM, traceShowM}` from `Monad` to `Applicative`
diff --git a/testsuite/tests/codeGen/should_run/CgStaticPointers.hs b/testsuite/tests/codeGen/should_run/CgStaticPointers.hs
index f7776b0..66363de 100644
--- a/testsuite/tests/codeGen/should_run/CgStaticPointers.hs
+++ b/testsuite/tests/codeGen/should_run/CgStaticPointers.hs
@@ -15,15 +15,15 @@ main = do
   print $ deRefStaticPtr (static g)
   print $ deRefStaticPtr p0 'a'
   print $ deRefStaticPtr (static t_field) $ T 'b'
+ where
+  g :: String
+  g = "found"
 
 lookupKey :: StaticPtr a -> IO a
 lookupKey p = unsafeLookupStaticPtr (staticKey p) >>= \case
   Just p -> return $ deRefStaticPtr p
   Nothing -> error $ "couldn't find " ++ show (staticPtrInfo p)
 
-g :: String
-g = "found"
-
 p0 :: Typeable a => StaticPtr (a -> a)
 p0 = static (\x -> x)
 
diff --git a/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout b/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout
index 0a223db..171ce47 100644
--- a/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout
+++ b/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout
@@ -1,5 +1,5 @@
-StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:1", spInfoSrcLoc = (10,32)}
-StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:2", spInfoSrcLoc = (11,33)}
-StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:0", spInfoSrcLoc = (21,13)}
-StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:3", spInfoSrcLoc = (13,33)}
-StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:4", spInfoSrcLoc = (14,33)}
+StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoSrcLoc = (10,32)}
+StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoSrcLoc = (11,33)}
+StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoSrcLoc = (21,13)}
+StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoSrcLoc = (13,33)}
+StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoSrcLoc = (14,33)}
diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr
index b7ff89c..0590eaa 100644
--- a/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr
+++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr
@@ -1,6 +1,5 @@
 
 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
+    ‘x’  is used in a static form but it is not closed.
+    In the expression: static x
+    In an equation for ‘f’: f x = static x
diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs
index 1a9baa3..141aa89 100644
--- a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs
+++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs
@@ -3,3 +3,11 @@
 module RnStaticPointersFail03 where
 
 f x = static (x . id)
+
+f0 x = static (k . id)
+  where
+    k = const (const () x)
+
+f1 x = static (k . id)
+  where
+    k = id
diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr
index d5a7270..8102662 100644
--- a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr
+++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr
@@ -1,6 +1,14 @@
 
 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
+    ‘x’ is used in a static form but it is not closed.
+    In the expression: static (x . id)
+    In an equation for ‘f’: f x = static (x . id)
+
+RnStaticPointersFail03.hs:7:8:
+     ‘k’ is used in a static form but it is not closed.
+     In the expression: static (k . id)
+     In an equation for ‘f0’:
+          f0 x
+            = static (k . id)
+            where
+                k = const (const () x)