Have addModFinalizer expose the local type environment.

Summary:
Kind inference in ghci was interfered when renaming of type splices
introduced the HsSpliced data constructor. This patch has kind
inference skip over it.

Test Plan: ./validate

Reviewers: simonpj, rrnewton, austin, goldfire, bgamari

Reviewed By: goldfire, bgamari

Subscribers: thomie, mboes

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

GHC Trac Issues: #12985

14 files changed, 305 insertions, 206 deletions

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 1eacd73e0a..fa2007057b 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -67,7 +67,6 @@ 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
@@ -390,12 +389,12 @@ lintCoreBindings dflags pass local_in_scope binds
                       _              -> True
 
     -- See Note [Checking StaticPtrs]
-    check_static_ptrs = xopt LangExt.StaticPointers dflags &&
-                        case pass of
-                          CoreDoFloatOutwards _ -> True
-                          CoreTidy              -> True
-                          CorePrep              -> True
-                          _                     -> False
+    check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere
+                      | otherwise = case pass of
+                          CoreDoFloatOutwards _ -> AllowAtTopLevel
+                          CoreTidy              -> RejectEverywhere
+                          CorePrep              -> AllowAtTopLevel
+                          _                     -> AllowAnywhere
 
     binders = bindersOfBinds binds
     (_, dups) = removeDups compare binders
@@ -536,28 +535,32 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
                   | 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.
+-- in that it doesn't reject occurrences of the function 'makeStatic' when they
+-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@.
 --
 -- 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
-    , Just (fun, args) <- collectStaticPtrSatArgs rhs'
-    = flip fix binders0 $ \loopBinders binders -> case binders of
+lintRhs rhs = fmap lf_check_static_ptrs getLintFlags >>= go
+  where
+    -- Allow occurrences of 'makeStatic' at the top-level but produce errors
+    -- otherwise.
+    go AllowAtTopLevel
+      | (binders0, rhs') <- collectTyBinders rhs
+      , Just (fun, t, info, e) <- collectMakeStaticArgs rhs'
+      = foldr
         -- imitate @lintCoreExpr (Lam ...)@
-        var : vars -> addLoc (LambdaBodyOf var) $
-                      lintBinder var $ \var' ->
-                      do { body_ty <- loopBinders vars
-                         ; return $ mkLamType var' body_ty }
+        (\var loopBinders ->
+          addLoc (LambdaBodyOf var) $
+            lintBinder var $ \var' ->
+              do { body_ty <- loopBinders
+                 ; return $ mkLamType var' body_ty }
+        )
         -- imitate @lintCoreExpr (App ...)@
-        [] -> do
-          fun_ty <- lintCoreExpr fun
-          addLoc (AnExpr rhs') $ lintCoreArgs fun_ty args
--- Rejects applications of the data constructor @StaticPtr@ if it finds any.
-lintRhs rhs = lintCoreExpr rhs
+        (do fun_ty <- lintCoreExpr fun
+            addLoc (AnExpr rhs') $ lintCoreArgs fun_ty [Type t, info, e]
+        )
+        binders0
+    go _ = lintCoreExpr rhs
 
 lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
 lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
@@ -673,11 +676,10 @@ lintCoreExpr e@(App _ _)
          -- 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
+           Var b | lf_check_static_ptrs lf /= AllowAnywhere
+                 , idName b == makeStaticName
                  -> do
-              failWithL $ text "Found StaticPtr nested in an expression: " <+>
+              failWithL $ text "Found makeStatic nested in an expression: " <+>
                           ppr e
            _     -> go
   where
@@ -1609,13 +1611,24 @@ 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]
+       , lf_check_static_ptrs          :: StaticPtrCheck
+                                             -- ^ See Note [Checking StaticPtrs]
     }
 
+-- See Note [Checking StaticPtrs]
+data StaticPtrCheck
+    = AllowAnywhere
+        -- ^ Allow 'makeStatic' to occur anywhere.
+    | AllowAtTopLevel
+        -- ^ Allow 'makeStatic' calls at the top-level only.
+    | RejectEverywhere
+        -- ^ Reject any 'makeStatic' occurrence.
+  deriving Eq
+
 defaultLintFlags :: LintFlags
 defaultLintFlags = LF { lf_check_global_ids = False
                       , lf_check_inline_loop_breakers = True
-                      , lf_check_static_ptrs = False
+                      , lf_check_static_ptrs = AllowAnywhere
                       }
 
 newtype LintM a =
@@ -1635,30 +1648,17 @@ Note [Checking StaticPtrs]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 See SimplCore Note [Grand plan for static forms] for an overview.
 
-Every occurrence of the data constructor @StaticPtr@ should be moved
-to the top level by the FloatOut pass.  It's vital that we don't have
-nested StaticPtr uses after CorePrep, because we populate the Static
+Every occurrence of the function 'makeStatic' should be moved to the
+top level by the FloatOut pass.  It's vital that we don't have nested
+'makeStatic' occurrences after CorePrep, because we populate the Static
 Pointer Table from the top-level bindings. See SimplCore Note [Grand
 plan for static forms].
 
 The linter checks that no occurrence is left behind, nested within an
-expression. The check is enabled only:
-
-* After the FloatOut, CorePrep, and CoreTidy passes.
-  We could check more often, but the condition doesn't hold until
-  after the first FloatOut pass.
-
-* When the module uses the StaticPointers language extension. This is
-  a little hack.  This optimization arose from the need to compile
-  GHC.StaticPtr, which otherwise would be rejected because of the
-  following binding for the StaticPtr data constructor itself:
-
-    StaticPtr = \a b1 b2 b3 b4 -> StaticPtr a b1 b2 b3 b4
-
-  which contains an application of `StaticPtr` nested within the
-  lambda abstractions.  This binding is injected by CorePrep.
-
-  Note that GHC.StaticPtr is itself compiled without -XStaticPointers.
+expression. The check is enabled only after the FloatOut, CorePrep,
+and CoreTidy passes and only if the module uses the StaticPointers
+language extension. Checking more often doesn't help since the condition
+doesn't hold until after the first FloatOut pass.
 
 Note [Type substitution]
 ~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index c611e0bba4..44d3dc6f19 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -48,13 +48,13 @@ module CoreUtils (
         stripTicksE, stripTicksT,
 
         -- * StaticPtr
-        collectStaticPtrSatArgs
+        collectMakeStaticArgs
     ) where
 
 #include "HsVersions.h"
 
 import CoreSyn
-import PrelNames ( staticPtrDataConName )
+import PrelNames ( makeStaticName )
 import PprCore
 import CoreFVs( exprFreeVars )
 import Var
@@ -2217,16 +2217,13 @@ isEmptyTy ty
 *****************************************************
 -}
 
--- | @collectStaticPtrSatArgs e@ yields @Just (s, args)@ when @e = s args@
--- and @s = StaticPtr@ and the application of @StaticPtr@ is saturated.
+-- | @collectMakeStaticArgs (makeStatic t info e)@ yields
+-- @Just (makeStatic, t, info, e)@.
 --
--- Yields @Nothing@ otherwise.
-collectStaticPtrSatArgs :: Expr b -> Maybe (Expr b, [Arg b])
-collectStaticPtrSatArgs e
-    | (fun@(Var b), args, _) <- collectArgsTicks (const True) e
-    , Just con <- isDataConId_maybe b
-    , dataConName con == staticPtrDataConName
-    , length args == 5
-    = Just (fun, args)
-collectStaticPtrSatArgs _
-    = Nothing
+-- Returns @Nothing@ for every other expression.
+collectMakeStaticArgs
+  :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
+collectMakeStaticArgs e
+    | (fun@(Var b), [Type t, info, arg], _) <- collectArgsTicks (const True) e
+    , idName b == makeStaticName = Just (fun, t, info, arg)
+collectMakeStaticArgs _          = Nothing
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 214cb0bb32..9c0c1759fb 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -27,7 +27,6 @@ import FamInstEnv( topNormaliseType )
 import DsMeta
 import HsSyn
 
-import Platform
 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
 --     needs to see source types
 import TcType
@@ -56,11 +55,7 @@ import Bag
 import Outputable
 import PatSyn
 
-import Data.List        ( intercalate )
-import Data.IORef       ( atomicModifyIORef' )
-
 import Control.Monad
-import GHC.Fingerprint
 
 {-
 ************************************************************************
@@ -423,24 +418,17 @@ dsExpr (PArrSeq _ _)
 Static Pointers
 ~~~~~~~~~~~~~~~
 
+See Note [Grand plan for static forms] in SimplCore for an overview.
+
     g = ... static f ...
 ==>
-    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"
+    g = ... makeStatic (StaticPtrInfo "pkg key" "module" loc) f ...
 -}
 
 dsExpr (HsStatic _ expr@(L loc _)) = do
     expr_ds <- dsLExpr expr
     let ty = exprType expr_ds
-    staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName
-    staticPtrDataCon     <- dsLookupDataCon staticPtrDataConName
+    makeStaticId <- dsLookupGlobalId makeStaticName
 
     dflags <- getDynFlags
     let (line, col) = case loc of
@@ -452,48 +440,18 @@ dsExpr (HsStatic _ expr@(L loc _)) = do
                      [ Type intTy              , Type intTy
                      , mkIntExprInt dflags line, mkIntExprInt dflags col
                      ]
+
     this_mod <- getModule
+    staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName
     info <- mkConApp staticPtrInfoDataCon <$>
             (++[srcLoc]) <$>
             mapM mkStringExprFS
                  [ unitIdFS $ moduleUnitId this_mod
                  , moduleNameFS $ moduleName this_mod
                  ]
-    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
-
-    mkStaticPtrFingerprint :: Module -> DsM Fingerprint
-    mkStaticPtrFingerprint this_mod = do
-      n <- mkGenPerModuleNum this_mod
-      return $ fingerprintString $ intercalate ":"
-        [ unitIdString $ moduleUnitId this_mod
-        , moduleNameString $ moduleName this_mod
-        , 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
+    putSrcSpanDs loc $ return $
+      mkCoreApps (Var makeStaticId) [ Type ty, info, expr_ds ]
 
 {-
 \noindent
diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs
index 9ec970f453..694c874711 100644
--- a/compiler/main/StaticPtrTable.hs
+++ b/compiler/main/StaticPtrTable.hs
@@ -46,79 +46,146 @@
 --
 
 {-# LANGUAGE ViewPatterns #-}
-module StaticPtrTable (sptModuleInitCode) where
+module StaticPtrTable (sptCreateStaticBinds) where
 
--- See SimplCore Note [Grand plan for static forms]
+-- See SimplCore Note [Grand plan for static forms] for an overview.
 
 import CLabel
 import CoreSyn
+import CoreUtils (collectMakeStaticArgs)
 import DataCon
+import DynFlags
+import HscTypes
 import Id
-import Literal
 import Module
+import Name
 import Outputable
+import Platform
 import PrelNames
+import Type
 
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.State
+import Data.List
 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.
+-- | Replaces all bindings of the form
 --
--- A bind is considered a static entry if it is an application of the
--- data constructor @StaticPtr@.
+-- > b = /\ ... -> makeStatic info value
 --
-sptModuleInitCode :: Module -> CoreProgram -> SDoc
-sptModuleInitCode this_mod binds =
-    sptInitCode $ catMaybes
-                $ map (\(b, e) -> ((,) b) <$> staticPtrFp e)
-                $ flattenBinds binds
+--  with
+--
+-- > b = /\ ... -> StaticPtr key info value
+--
+--  where a distinct key is generated for each binding.
+--
+-- It also yields the C stub that inserts these bindings into the static
+-- pointer table.
+sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram
+                     -> IO (SDoc, CoreProgram)
+sptCreateStaticBinds hsc_env this_mod binds = do
+    (fps, binds') <- evalStateT (go [] [] binds) 0
+    return (sptModuleInitCode this_mod fps, 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
+    go fps bs xs = case xs of
+      []        -> return (reverse fps, reverse bs)
+      bnd : xs' -> do
+        (fps', bnd') <- replaceStaticBind bnd
+        go (reverse fps' ++ fps) (bnd' : bs) xs'
+
+    -- Generates keys and replaces 'makeStatic' with 'StaticPtr'.
+    --
+    -- The 'Int' state is used to produce a different key for each binding.
+    replaceStaticBind :: CoreBind
+                      -> StateT Int IO ([(Id, Fingerprint)], CoreBind)
+    replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e
+                                        return (maybeToList mfp, NonRec b' e')
+    replaceStaticBind (Rec rbs) = do
+      (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs
+      return (catMaybes mfps, Rec rbs')
+
+    replaceStatic :: Id -> CoreExpr
+                  -> StateT Int IO (Maybe (Id, Fingerprint), (Id, CoreExpr))
+    replaceStatic b e@(collectTyBinders -> (tvs, e0)) =
+      case collectMakeStaticArgs e0 of
+        Nothing      -> return (Nothing, (b, e))
+        Just (_, t, info, arg) -> do
+          (fp, e') <- mkStaticBind t info arg
+          return (Just (b, fp), (b, foldr Lam e' tvs))
+
+    mkStaticBind :: Type -> CoreExpr -> CoreExpr
+                 -> StateT Int IO (Fingerprint, CoreExpr)
+    mkStaticBind t info e = do
+      i <- get
+      put (i + 1)
+      let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i
+          dflags = hsc_dflags hsc_env
 
-    fromPlatformWord64Rep (MachWord w)   = Just w
-    fromPlatformWord64Rep (MachWord64 w) = Just w
-    fromPlatformWord64Rep _              = Nothing
+      staticPtrDataCon <- lift $ lookupDataCon staticPtrDataConName
+      return (fp, mkConApp staticPtrDataCon
+                               [ Type t
+                               , mkWord64LitWordRep dflags w0
+                               , mkWord64LitWordRep dflags w1
+                               , info
+                               , e ])
 
-    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
-          ]
-      ]
+    mkStaticPtrFingerprint :: Int -> Fingerprint
+    mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"
+        [ unitIdString $ moduleUnitId this_mod
+        , moduleNameString $ moduleName this_mod
+        , show n
+        ]
 
+    -- 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
+
+    lookupDataCon :: Name -> IO DataCon
+    lookupDataCon n = lookupTypeHscEnv hsc_env n >>=
+                        maybe (getError n) (return . tyThingDataCon)
+
+    getError n = pprPanic "sptCreateStaticBinds.get: not found" $
+      text "Couldn't find" <+> ppr n
+
+-- | @sptModuleInitCode module fps@ is a C stub to insert the static entries
+-- of @module@ into the static pointer table.
+--
+-- @fps@ is a list associating each binding corresponding to a static entry with
+-- its fingerprint.
+sptModuleInitCode :: Module -> [(Id, Fingerprint)] -> SDoc
+sptModuleInitCode _ [] = Outputable.empty
+sptModuleInitCode 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, (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
+        ]
+    ]
+  where
     pprFingerprint :: Fingerprint -> SDoc
     pprFingerprint (Fingerprint w1 w2) =
       braces $ hcat $ punctuate comma
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index 52137a4cd7..dc7813b2f5 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -20,7 +20,7 @@ import CoreFVs
 import CoreTidy
 import CoreMonad
 import CorePrep
-import CoreUtils        (rhsIsStatic, collectStaticPtrSatArgs)
+import CoreUtils        (rhsIsStatic)
 import CoreStats        (coreBindsStats, CoreStats(..))
 import CoreLint
 import Literal
@@ -373,12 +373,12 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
               ; type_env2    = extendTypeEnvWithPatSyns tidy_patsyns type_env1
 
               ; tidy_type_env = tidyTypeEnv omit_prags type_env2
-
-              -- See Note [Injecting implicit bindings]
-              ; all_tidy_binds = implicit_binds ++ tidy_binds
-
-              -- See SimplCore Note [Grand plan for static forms]
-              ; spt_init_code = sptModuleInitCode mod all_tidy_binds
+              }
+            -- See SimplCore Note [Grand plan for static forms]
+        ; (spt_init_code, tidy_binds') <-
+             sptCreateStaticBinds hsc_env mod tidy_binds
+        ; let { -- See Note [Injecting implicit bindings]
+                all_tidy_binds = implicit_binds ++ tidy_binds'
 
               -- Get the TyCons to generate code for.  Careful!  We must use
               -- the untidied TypeEnv here, because we need
@@ -638,27 +638,19 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
   -- same list every time this module is compiled), in contrast to the
   -- bindings, which are ordered non-deterministically.
   init_work_list = zip init_ext_ids init_ext_ids
-  init_ext_ids   = sortBy (compare `on` getOccName) $
-                   map fst $ filter is_external flatten_binds
+  init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders
 
   -- 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, or
-  -- (d) it is a static pointer (see notes in StaticPtrTable.hs).
+  -- (c) it is the vectorised version of an imported Id.
   -- See Note [Which rules to expose]
-  is_external (id, e) = isExportedId id || id `elemVarSet` rule_rhs_vars
-                      || id `elemVarSet` vect_var_vs
-                      || isStaticPtrApp e
-
-  isStaticPtrApp :: CoreExpr -> Bool
-  isStaticPtrApp (collectTyBinders -> (_, e)) =
-    isJust $ collectStaticPtrSatArgs e
+  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars
+                 || id `elemVarSet` vect_var_vs
 
   rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules
   vect_var_vs    = mkVarSet [var_v | (var, var_v) <- eltsUDFM vect_vars, isGlobalId var]
 
-  flatten_binds    = flattenBinds binds
-  binders          = map fst flatten_binds
+  binders          = map fst $ flattenBinds binds
   implicit_binders = bindersOfBinds implicit_binds
   binder_set       = mkVarSet binders
 
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 41c9e36304..e7ad536ca9 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -383,6 +383,7 @@ basicKnownKeyNames
         , ghciIoClassName, ghciStepIoMName
 
         -- StaticPtr
+        , makeStaticName
         , staticPtrTyConName
         , staticPtrDataConName, staticPtrInfoDataConName
         , fromStaticPtrName
@@ -521,6 +522,9 @@ gHC_STACK_TYPES = mkBaseModule (fsLit "GHC.Stack.Types")
 gHC_STATICPTR :: Module
 gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")
 
+gHC_STATICPTR_INTERNAL :: Module
+gHC_STATICPTR_INTERNAL = mkBaseModule (fsLit "GHC.StaticPtr.Internal")
+
 gHC_FINGERPRINT_TYPE :: Module
 gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type")
 
@@ -1386,6 +1390,10 @@ frontendPluginTyConName :: Name
 frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey
 
 -- Static pointers
+makeStaticName :: Name
+makeStaticName =
+    varQual gHC_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey
+
 staticPtrInfoTyConName :: Name
 staticPtrInfoTyConName =
     tcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey
@@ -2220,6 +2228,9 @@ pushCallStackKey  = mkPreludeMiscIdUnique 518
 fromStaticPtrClassOpKey :: Unique
 fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 519
 
+makeStaticKey :: Unique
+makeStaticKey = mkPreludeMiscIdUnique 520
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
index ff780153a0..284bc4a925 100644
--- a/compiler/simplCore/SetLevels.hs
+++ b/compiler/simplCore/SetLevels.hs
@@ -66,7 +66,7 @@ import CoreSyn
 import CoreMonad        ( FloatOutSwitches(..) )
 import CoreUtils        ( exprType
                         , exprOkForSpeculation
-                        , collectStaticPtrSatArgs
+                        , collectMakeStaticArgs
                         )
 import CoreArity        ( exprBotStrictness_maybe )
 import CoreFVs          -- all of it
@@ -1187,7 +1187,7 @@ newLvlVar lvld_rhs
 
     mk_id uniq rhs_ty
       -- See Note [Grand plan for static forms] in SimplCore.
-      | isJust $ collectStaticPtrSatArgs $ snd $
+      | isJust $ collectMakeStaticArgs $ snd $
         collectTyBinders de_tagged_rhs
       = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
                             rhs_ty
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index 8e9a9c68bb..f049046ec4 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -1044,37 +1044,50 @@ Here is a running example:
   in a nested let, we are fine.
 
 * The desugarer replaces the static form with an application of the
-  data constructor 'StaticPtr' (defined in module GHC.StaticPtr of
+  function 'makeStatic' (defined in module GHC.StaticPtr.Internal of
   base).  So we get
 
    f x = let k = map toUpper
-         in ...(StaticPtr <fingerprint> k)...
+         in ...(makeStatic (StaticPtrInfo "pkg" "module" location) k)...
 
-* The simplifier runs the FloatOut pass which moves the applications
-  of 'StaticPtr' to the top level. Thus the FloatOut pass is always
-  executed, even when optimizations are disabled.  So we get
+* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic'
+  to the top level. Thus the FloatOut pass is always executed, even when
+  optimizations are disabled.  So we get
 
    k = map toUpper
-   static_ptr = StaticPtr <fingerprint> k
+   static_ptr = makeStatic info k
    f x = ...static_ptr...
 
   The FloatOut pass is careful to produce an /exported/ Id for a floated
-  'StaticPtr', so the binding is not removed by the simplifier (see #12207).
+  'makeStatic' call, so the binding is not removed or inlined by the
+  simplifier.
   E.g. the code for `f` above might look like
 
-    static_ptr = StaticPtr <fingerprint> k
-    f x = ...(staticKey static_ptr)...
+    static_ptr = makeStatic info k
+    f x = ...(case static_ptr of ...)...
 
-  which might correctly be simplified to
+  which might be simplified to
 
-    f x = ...<fingerprint>...
+    f x = ...(case makeStatic info k of ...)...
 
   BUT the top-level binding for static_ptr must remain, so that it can be
   collected to populate the Static Pointer Table.
 
-* The CoreTidy pass produces a C function which inserts all the
-  floated 'StaticPtr' in the static pointer table (see the call to
-  StaticPtrTable.sptModuleInitCode in TidyPgm). CoreTidy pass also
-  exports the Ids of floated 'StaticPtr's so they can be linked with
-  the C function.
+  Making the binding exported also has a necessary effect during the
+  CoreTidy pass.
+
+* The CoreTidy pass replaces all bindings of the form
+
+  b = /\ ... -> makeStatic info value
+
+  with
+
+  b = /\ ... -> StaticPtr key info value
+
+  where a distinct key is generated for each binding.
+
+  We produce also a C function which inserts all these bindings in the static
+  pointer table (see the call to StaticPtrTable.sptCreateStaticBinds in
+  TidyPgm). As the Ids of floated static pointers are exported, they can be
+  linked with the C function.
 -}
diff --git a/libraries/base/GHC/StaticPtr/Internal.hs b/libraries/base/GHC/StaticPtr/Internal.hs
new file mode 100644
index 0000000000..e75dfe8994
--- /dev/null
+++ b/libraries/base/GHC/StaticPtr/Internal.hs
@@ -0,0 +1,24 @@
+-- |
+-- Module      :  GHC.StaticPtr
+-- Copyright   :  (C) 2016 I/O Tweag
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  cvs-ghc@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Internal definitions not to be used by the user of StaticPtr's.
+
+-- By ignoring interface pragmas, we drop the stricness annotations
+-- of 'error', which otherwise biase GHC to conclude that any code
+-- using the static form would fail.
+{-# OPTIONS_GHC -fignore-interface-pragmas #-}
+module GHC.StaticPtr.Internal (makeStatic) where
+
+import GHC.StaticPtr(StaticPtr, StaticPtrInfo(..))
+
+{-# NOINLINE makeStatic #-}
+makeStatic :: StaticPtrInfo -> a -> StaticPtr a
+makeStatic (StaticPtrInfo pkg m (line, col)) _ =
+    error $ "makeStatic: Unresolved static form at " ++ pkg ++ ":" ++ m ++ ":"
+            ++ show line ++ ":" ++ show col
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index 22df434381..a4f0c7d990 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -312,6 +312,7 @@ Library
         Data.Functor.Utils
         Data.OldList
         Foreign.ForeignPtr.Imp
+        GHC.StaticPtr.Internal
         System.Environment.ExecutablePath
         System.CPUTime.Utils
 
diff --git a/testsuite/tests/codeGen/should_run/T12622.hs b/testsuite/tests/codeGen/should_run/T12622.hs
new file mode 100644
index 0000000000..81e5b04fa3
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T12622.hs
@@ -0,0 +1,19 @@
+-- Test that static pointers still work when the users try
+-- to unpack StaticPtr fields.
+{-# LANGUAGE StaticPointers #-}
+{-# LANGUAGE LambdaCase #-}
+
+import GHC.StaticPtr
+import T12622_A
+
+g = True
+
+main :: IO ()
+main = do
+  let T s = sg :: T (Bool -> Bool)
+  lookupKey s >>= \f -> print (f True)
+
+lookupKey :: StaticPtr a -> IO a
+lookupKey p = unsafeLookupStaticPtr (staticKey p) >>= \case
+  Just p -> return $ deRefStaticPtr p
+  Nothing -> error $ "couldn't find " ++ show (staticPtrInfo p)
diff --git a/testsuite/tests/codeGen/should_run/T12622.stdout b/testsuite/tests/codeGen/should_run/T12622.stdout
new file mode 100644
index 0000000000..0ca95142bb
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T12622.stdout
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/codeGen/should_run/T12622_A.hs b/testsuite/tests/codeGen/should_run/T12622_A.hs
new file mode 100644
index 0000000000..6c85cc53e9
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T12622_A.hs
@@ -0,0 +1,15 @@
+-- A.hs
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE StaticPointers #-}
+module T12622_A where
+
+import Data.Typeable
+import GHC.StaticPtr
+
+g :: a -> Bool
+g _ = True
+
+data T a = T {-# UNPACK #-} !(StaticPtr a)
+
+sg :: Typeable a => T (a -> Bool)
+sg = T (static g)
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index 3b025790f8..5059cb4483 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -146,6 +146,7 @@ test('PopCnt', omit_ways(['ghci']), multi_compile_and_run,
                  ['PopCnt', [('PopCnt_cmm.cmm', '')], ''])
 test('T12059', normal, compile_and_run, [''])
 test('T12433', normal, compile_and_run, [''])
+test('T12622', normal, multimod_compile_and_run, ['T12622', '-O'])
 test('T12757', normal, compile_and_run, [''])
 test('T12855', normal, compile_and_run, [''])
 test('T9577', [ unless(arch('x86_64') or arch('i386'),skip),