StaticPointers: Move floating into CorePrep WIP

8 files changed, 151 insertions, 211 deletions

diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index f20dbcc62b..a684bc048e 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -980,13 +980,6 @@ lintIdOcc var nargs
         ; ensureEqTys occ_ty bndr_ty $
           mkBndrOccTypeMismatchMsg bndr var bndr_ty occ_ty
 
-          -- Check for a nested occurrence of the StaticPtr constructor.
-          -- See Note [Checking StaticPtrs].
-        ; lf <- getLintFlags
-        ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $
-            checkL (idName var /= makeStaticName) $
-              text "Found makeStatic nested in an expression"
-
         ; checkDeadIdOcc var
         ; checkJoinOcc var nargs
 
diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs
index 2d69e8eb04..b9c21b4945 100644
--- a/compiler/GHC/Core/Opt/SetLevels.hs
+++ b/compiler/GHC/Core/Opt/SetLevels.hs
@@ -83,7 +83,6 @@ import GHC.Core.Utils   ( exprType, exprIsHNF
                         , exprOkForSpeculation
                         , exprIsTopLevelBindable
                         , isExprLevPoly
-                        , collectMakeStaticArgs
                         , mkLamTypes
                         )
 import GHC.Core.Opt.Arity   ( exprBotStrictness_maybe )
@@ -105,7 +104,7 @@ import GHC.Types.Var.Env
 import GHC.Types.Literal      ( litIsTrivial )
 import GHC.Types.Demand       ( DmdSig, Demand, isStrUsedDmd, splitDmdSig, prependArgsDmdSig )
 import GHC.Types.Cpr          ( mkCprSig, botCpr )
-import GHC.Types.Name         ( getOccName, mkSystemVarName )
+import GHC.Types.Name         ( getOccName )
 import GHC.Types.Name.Occurrence ( occNameString )
 import GHC.Types.Unique       ( hasKey )
 import GHC.Types.Tickish      ( tickishIsCode )
@@ -684,7 +683,7 @@ lvlMFE env strict_ctxt ann_expr
                               join_arity_maybe
                               ann_expr
                   -- Treat the expr just like a right-hand side
-       ; var <- newLvlVar expr1 join_arity_maybe is_mk_static
+       ; var <- newLvlVar expr1 join_arity_maybe
        ; let var2 = annotateBotStr var float_n_lams mb_bot_str
        ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)
                      (mkVarApps (Var var2) abs_vars)) }
@@ -706,7 +705,7 @@ lvlMFE env strict_ctxt ann_expr
                          Case expr1 (stayPut l1r ubx_bndr) dc_res_ty
                              [Alt DEFAULT [] (mkConApp dc [Var ubx_bndr])]
 
-       ; var <- newLvlVar float_rhs Nothing is_mk_static
+       ; var <- newLvlVar float_rhs Nothing
        ; let l1u      = incMinorLvlFrom env
              use_expr = Case (mkVarApps (Var var) abs_vars)
                              (stayPut l1u bx_bndr) expr_ty
@@ -743,12 +742,10 @@ lvlMFE env strict_ctxt ann_expr
 
     join_arity_maybe = Nothing
 
-    is_mk_static = isJust (collectMakeStaticArgs expr)
-        -- Yuk: See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable
 
         -- A decision to float entails let-binding this thing, and we only do
         -- that if we'll escape a value lambda, or will go to the top level.
-    float_me = saves_work || saves_alloc || is_mk_static
+    float_me = saves_work || saves_alloc
 
     -- We can save work if we can move a redex outside a value lambda
     -- But if float_is_new_lam is True, then the redex is wrapped in a
@@ -1742,9 +1739,8 @@ newPolyBndrs dest_lvl
 
 newLvlVar :: LevelledExpr        -- The RHS of the new binding
           -> Maybe JoinArity     -- Its join arity, if it is a join point
-          -> Bool                -- True <=> the RHS looks like (makeStatic ...)
           -> LvlM Id
-newLvlVar lvld_rhs join_arity_maybe is_mk_static
+newLvlVar lvld_rhs join_arity_maybe
   = do { uniq <- getUniqueM
        ; return (add_join_info (mk_id uniq rhs_ty))
        }
@@ -1754,11 +1750,6 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static
     rhs_ty        = exprType de_tagged_rhs
 
     mk_id uniq rhs_ty
-      -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
-      | is_mk_static
-      = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
-                            rhs_ty
-      | otherwise
       = mkSysLocal (mkFastString "lvl") uniq Many rhs_ty
 
 -- | Clone the binders bound by a single-alternative case.
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 30c28a6db2..7ffa96de7d 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE BangPatterns #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# LANGUAGE ViewPatterns #-}
 
 {-
 (c) The University of Glasgow, 1994-2006
@@ -69,16 +70,21 @@ import GHC.Types.Id
 import GHC.Types.Id.Info
 import GHC.Types.Id.Make ( realWorldPrimId, mkPrimOpId )
 import GHC.Types.Basic
-import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName )
-import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
+import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName, Name, mkExternalName, mkVarOcc )
+import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc, noSrcSpan )
 import GHC.Types.Literal
 import GHC.Types.Tickish
 import GHC.Types.TyThing
 import GHC.Types.Unique.Supply
 
-import Data.List        ( unfoldr )
+import Data.List        ( unfoldr, intercalate )
 import Data.Functor.Identity
 import Control.Monad
+import GHC.Fingerprint.Type
+import GHC.Linker.Types
+import GHC.Utils.Fingerprint
+import Control.Monad.Trans.Writer
+import GHC.Types.Unique
 
 {-
 -- ---------------------------------------------------------------------------
@@ -237,42 +243,52 @@ type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'
 ************************************************************************
 -}
 
+type CorePrepM a = WriterT [(SptEntry, CoreBind)] UniqSM a
+
+
 corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
-            -> IO CoreProgram
+            -> IO (CoreProgram, [SptEntry])
 corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
     withTiming logger
                (text "CorePrep"<+>brackets (ppr this_mod))
-               (\a -> a `seqList` ()) $ do
+               (\(a, b) -> a `seqList` b `seqList` ()) $ do
     us <- mkSplitUniqSupply 's'
-    initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env
+    initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env this_mod
 
     let
         implicit_binds = mkDataConWorkers dflags mod_loc data_tycons
             -- NB: we must feed mkImplicitBinds through corePrep too
             -- so that they are suitably cloned and eta-expanded
 
-        binds_out = initUs_ us $ do
-                      floats1 <- corePrepTopBinds initialCorePrepEnv binds
-                      floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
-                      return (deFloatTop (floats1 `appendFloats` floats2))
+        ((binds_out, spe), _)
+                    = initUs_ us $ runWriterT $ do
+                      (floats1, spt1) <- listen $ corePrepTopBinds initialCorePrepEnv binds
+                      (floats2, spt2) <- listen $ corePrepTopBinds initialCorePrepEnv implicit_binds
+                      let (spe_floats, spt_binds) = unzip $ spt1 ++ spt2
+                      floats3 <- corePrepTopBinds initialCorePrepEnv spt_binds
+                      return (deFloatTop (floats3 `appendFloats` floats1 `appendFloats` floats2 ), spe_floats)
 
     endPassIO hsc_env alwaysQualify CorePrep binds_out []
-    return binds_out
+    return (binds_out, spe)
   where
     dflags = hsc_dflags hsc_env
     logger = hsc_logger hsc_env
 
-corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr
-corePrepExpr hsc_env expr = do
+
+corePrepExpr :: HscEnv -> Module -> CoreExpr -> IO CoreExpr
+corePrepExpr hsc_env this_mod expr = do
     let logger = hsc_logger hsc_env
     withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do
       us <- mkSplitUniqSupply 's'
-      initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env
-      let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)
+      initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env this_mod
+      -- MP: At the moment this code-path is only hit when compiling an expression for TH,
+      -- where static forms are disallowed for some reason. It should probably also
+      -- return the SPT entries which can be loaded into the interpreter.
+      let (new_expr, _) = initUs_ us $ runWriterT (cpeBodyNF initialCorePrepEnv expr)
       putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)
       return new_expr
 
-corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats
+corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> CorePrepM Floats
 -- Note [Floating out of top level bindings]
 corePrepTopBinds initialCorePrepEnv binds
   = go initialCorePrepEnv binds
@@ -577,7 +593,7 @@ Other related tickets:
 -}
 
 cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
-        -> UniqSM (CorePrepEnv,
+        -> CorePrepM (CorePrepEnv,
                    Floats,         -- Floating value bindings
                    Maybe CoreBind) -- Just bind' <=> returned new bind; no float
                                    -- Nothing <=> added bind' to floats instead
@@ -644,7 +660,7 @@ cpeBind top_lvl env (Rec pairs)
 ---------------
 cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
         -> CorePrepEnv -> OutId -> CoreExpr
-        -> UniqSM (Floats, CpeRhs)
+        -> CorePrepM (Floats, CpeRhs)
 -- Used for all bindings
 -- The binder is already cloned, hence an OutId
 cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
@@ -695,7 +711,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
       | otherwise
       = dontFloat floats rhs
 
-dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)
+dontFloat :: Floats -> CpeRhs -> CorePrepM (Floats, CpeBody)
 -- Non-empty floats, but do not want to float from rhs
 -- So wrap the rhs in the floats
 -- But: rhs1 might have lambdas, and we can't
@@ -722,7 +738,7 @@ it seems good for CorePrep to be robust.
 
 ---------------
 cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr
-            -> UniqSM (JoinId, CpeRhs)
+            -> CorePrepM (JoinId, CpeRhs)
 -- Used for all join bindings
 -- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils
 cpeJoinPair env bndr rhs
@@ -763,7 +779,7 @@ for us to mess with the arity because a join point is never exported.
 --              CpeRhs: produces a result satisfying CpeRhs
 -- ---------------------------------------------------------------------------
 
-cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
+cpeRhsE :: CorePrepEnv -> CoreExpr -> CorePrepM (Floats, CpeRhs)
 -- If
 --      e  ===>  (bs, e')
 -- then
@@ -880,7 +896,7 @@ cpeRhsE env (Case scrut bndr ty alts)
 -- let-bound using 'wrapBinds').  Generally you want this, esp.
 -- when you've reached a binding form (e.g., a lambda) and
 -- floating any further would be incorrect.
-cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
+cpeBodyNF :: CorePrepEnv -> CoreExpr -> CorePrepM CpeBody
 cpeBodyNF env expr
   = do { (floats, body) <- cpeBody env expr
        ; return (wrapBinds floats body) }
@@ -895,14 +911,14 @@ cpeBodyNF env expr
 --      case (let x = y in z) of ...
 --      ==> let x = y in case z of ...
 --
-cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
+cpeBody :: CorePrepEnv -> CoreExpr -> CorePrepM (Floats, CpeBody)
 cpeBody env expr
   = do { (floats1, rhs) <- cpeRhsE env expr
        ; (floats2, body) <- rhsToBody rhs
        ; return (floats1 `appendFloats` floats2, body) }
 
 --------
-rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
+rhsToBody :: CpeRhs -> CorePrepM (Floats, CpeBody)
 -- Remove top level lambdas by let-binding
 
 rhsToBody (Tick t expr)
@@ -946,7 +962,7 @@ instance Outputable ArgInfo where
   ppr (CpeCast co) = text "cast" <+> ppr co
   ppr (CpeTick tick) = text "tick" <+> ppr tick
 
-cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
+cpeApp :: CorePrepEnv -> CoreExpr -> CorePrepM (Floats, CpeRhs)
 -- May return a CpeRhs because of saturating primops
 cpeApp top_env expr
   = do { let (terminal, args, depth) = collect_args expr
@@ -979,7 +995,7 @@ cpeApp top_env expr
             -> CoreExpr
             -> [ArgInfo]
             -> Int
-            -> UniqSM (Floats, CpeRhs)
+            -> CorePrepM (Floats, CpeRhs)
     cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth
         | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and
             -- See Note [lazyId magic] in GHC.Types.Id.Make
@@ -1044,6 +1060,16 @@ cpeApp top_env expr
             Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest (n-2)
             _          -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) (n-1)
              -- TODO: What about casts?
+    cpe_app env (Var f) (CpeApp (Type t1) : CpeApp loc : CpeApp arg : rest) n
+      | makeStaticName == idName f
+      = do
+          (float_var, ty_vars, fp, new_expr) <- cpe_mk_static_form env t1 loc arg
+          let bind = NonRec float_var new_expr
+          tell ([(SptEntry float_var fp, bind)])
+          cpe_app env (mkTyApps (Var float_var) (map mkTyVarTy ty_vars))rest n
+
+
+
 
     cpe_app env (Var v) args depth
       = do { v1 <- fiddleCCall v
@@ -1098,7 +1124,7 @@ cpeApp top_env expr
         -> CpeApp
         -> Floats
         -> [Demand]
-        -> UniqSM (CpeApp, Floats)
+        -> CorePrepM (CpeApp, Floats)
     rebuild_app _ [] app floats ss
       = assert (null ss) -- make sure we used all the strictness info
         return (app, floats)
@@ -1373,7 +1399,7 @@ okCpeArg expr    = not (exprIsTrivial expr)
 
 -- This is where we arrange that a non-trivial argument is let-bound
 cpeArg :: CorePrepEnv -> Demand
-       -> CoreArg -> UniqSM (Floats, CpeArg)
+       -> CoreArg -> CorePrepM (Floats, CpeArg)
 cpeArg env dmd arg
   = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda
        ; let arg_ty      = exprType arg1
@@ -1425,7 +1451,7 @@ applications here as well but due to this fragility (see #16846) we now deal
 with this another way, as described in Note [Primop wrappers] in GHC.Builtin.PrimOps.
 -}
 
-maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
+maybeSaturate :: Id -> CpeApp -> Int -> CorePrepM CpeRhs
 maybeSaturate fn expr n_args
   | hasNoBinding fn        -- There's no binding
   = return sat_expr
@@ -1836,16 +1862,21 @@ data CorePrepEnv
         , cpe_convertNumLit   :: LitNumType -> Integer -> Maybe CoreExpr
         -- ^ Convert some numeric literals (Integer, Natural) into their
         -- final Core form
+        , cpe_mk_static_form :: Type -> CoreExpr -> CoreExpr -> CorePrepM (Id, [TypeVar], Fingerprint, CoreExpr)
+        -- ^ Convert some numeric literals (Integer, Natural) into their
+        -- final Core form
     }
 
-mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv
-mkInitialCorePrepEnv hsc_env = do
+mkInitialCorePrepEnv :: HscEnv -> Module -> IO CorePrepEnv
+mkInitialCorePrepEnv hsc_env this_mod = do
    convertNumLit <- mkConvertNumLiteral hsc_env
+   mk_static_form <- mkMkStaticForm hsc_env this_mod
    return $ CPE
-      { cpe_dynFlags      = hsc_dflags hsc_env
+      { cpe_dynFlags      =  hsc_dflags hsc_env
       , cpe_env           = emptyVarEnv
       , cpe_tyco_env      = Nothing
       , cpe_convertNumLit = convertNumLit
+      , cpe_mk_static_form = mk_static_form
       }
 
 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
@@ -1982,10 +2013,10 @@ subst_cv_bndr tce cv
 -- Cloning binders
 -- ---------------------------------------------------------------------------
 
-cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])
+cpCloneBndrs :: CorePrepEnv -> [InVar] -> CorePrepM (CorePrepEnv, [OutVar])
 cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs
 
-cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
+cpCloneBndr  :: CorePrepEnv -> InVar -> CorePrepM (CorePrepEnv, OutVar)
 cpCloneBndr env bndr
   | isTyVar bndr
   = return (cpSubstTyVarBndr env bndr)
@@ -2041,7 +2072,7 @@ see Note [Preserve evaluatedness] in GHC.Core.Tidy.
 -- to give the code generator a handle to hang it on
 -- ---------------------------------------------------------------------------
 
-fiddleCCall :: Id -> UniqSM Id
+fiddleCCall :: Id -> CorePrepM Id
 fiddleCCall id
   | isFCallId id = (id `setVarUnique`) <$> getUniqueM
   | otherwise    = return id
@@ -2050,13 +2081,12 @@ fiddleCCall id
 -- Generating new binders
 -- ---------------------------------------------------------------------------
 
-newVar :: Type -> UniqSM Id
+newVar :: Type -> CorePrepM Id
 newVar ty
  = seqType ty `seq` do
      uniq <- getUniqueM
      return (mkSysLocalOrCoVar (fsLit "sat") uniq Many ty)
 
-
 ------------------------------------------------------------------------------
 -- Floating ticks
 -- ---------------------------------------------------------------------------
@@ -2204,3 +2234,59 @@ mkConvertNumLiteral hsc_env = do
 
    return convertNumLit
 
+-- Static Forms
+
+mkMkStaticForm :: HscEnv -> Module -> IO (Type -> CoreExpr -> CoreExpr -> CorePrepM (Id, [TyVar], Fingerprint, CoreExpr))
+mkMkStaticForm hsc_env this_mod = do
+      staticPtrInfoDataCon <- lookupDataCon staticPtrInfoDataConName
+      staticPtrDataCon <- lookupDataCon staticPtrDataConName
+      fs <- mapM (mkStringExprFSWith lookupId)
+                   [ unitFS $ moduleUnit this_mod
+                   , moduleNameFS $ moduleName this_mod
+                   ]
+      return $ \t srcLoc e -> do
+        key <- getUniqueM
+        let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint (getKey key)
+            info = mkConApp staticPtrInfoDataCon (fs ++ [srcLoc])
+
+            external_name = mkExternalName key this_mod
+                              (mkVarOcc $ "static_ptr" ++ show (getKey key))
+                              noSrcSpan
+            external_id = mkExportedVanillaId external_name (exprType res_e)
+
+            type_vars = tyCoVarsOfTypeWellScoped t
+
+            res_e = mkLams type_vars
+                      $ mkConApp staticPtrDataCon
+                                 [ Type t
+                                 , mkWord64LitWordRep platform w0
+                                 , mkWord64LitWordRep platform w1
+                                 , info
+                                 , e ]
+        -- The module interface of GHC.StaticPtr should be loaded at least
+        -- when looking up 'fromStatic' during type-checking.
+        return (external_id, type_vars, fp, res_e)
+
+  where
+    dflags = hsc_dflags hsc_env
+    platform = targetPlatform dflags
+
+    mkStaticPtrFingerprint :: Int -> Fingerprint
+    mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"
+        [ unitString $ moduleUnit this_mod
+        , moduleNameString $ moduleName this_mod
+        , show n
+        ]
+
+    -- Choose either 'Word64#' or 'Word#' to represent the arguments of the
+    -- 'Fingerprint' data constructor.
+    mkWord64LitWordRep platform =
+      case platformWordSize platform of
+        PW4 -> mkWord64LitWord64
+        PW8 -> mkWordLit platform . toInteger
+
+    lookupId :: Name -> IO Id
+    lookupId n = tyThingId <$> lookupGlobal hsc_env n
+
+    lookupDataCon :: Name -> IO DataCon
+    lookupDataCon n = tyThingDataCon <$> lookupGlobal hsc_env n
\ No newline at end of file
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 0ee84f7ca8..9711474974 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -235,6 +235,7 @@ import Data.Set (Set)
 import Data.Functor
 import Control.DeepSeq (force)
 import Data.Bifunctor (first)
+import GHC.Iface.Tidy.StaticPtrTable
 
 {- **********************************************************************
 %*                                                                      *
@@ -1587,7 +1588,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
         -------------------
         -- PREPARE FOR CODE GENERATION
         -- Do saturation and convert to A-normal form
-        (prepd_binds) <- {-# SCC "CorePrep" #-}
+        (prepd_binds, spt_entries) <- {-# SCC "CorePrep" #-}
                        corePrepPgm hsc_env this_mod location
                                    core_binds data_tycons
 
@@ -1606,6 +1607,8 @@ hscGenHardCode hsc_env cgguts location output_filename = do
               | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info
               | otherwise = mempty
 
+            spt_init_code = sptModuleInitCode platform this_mod spt_entries
+
         ------------------  Code generation ------------------
         -- The back-end is streamed: each top-level function goes
         -- from Stg all the way to asm before dealing with the next
@@ -1634,6 +1637,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
 
             let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init
                                                   `appendStubC` cgIPEStub st
+                                                  `appendStubC` spt_init_code
 
             (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)
                 <- {-# SCC "codeOutput" #-}
@@ -1656,8 +1660,8 @@ hscInteractive hsc_env cgguts location = do
                cg_binds    = core_binds,
                cg_tycons   = tycons,
                cg_foreign  = foreign_stubs,
-               cg_modBreaks = mod_breaks,
-               cg_spt_entries = spt_entries } = cgguts
+               cg_modBreaks = mod_breaks
+               } = cgguts
 
         data_tycons = filter isDataTyCon tycons
         -- cg_tycons includes newtypes, for the benefit of External Core,
@@ -1666,7 +1670,7 @@ hscInteractive hsc_env cgguts location = do
     -------------------
     -- PREPARE FOR CODE GENERATION
     -- Do saturation and convert to A-normal form
-    prepd_binds <- {-# SCC "CorePrep" #-}
+    (prepd_binds, spt_entries) <- {-# SCC "CorePrep" #-}
                    corePrepPgm hsc_env this_mod location core_binds data_tycons
 
     (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
@@ -1983,7 +1987,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
 
     {- Prepare For Code Generation -}
     -- Do saturation and convert to A-normal form
-    prepd_binds <- {-# SCC "CorePrep" #-}
+    (prepd_binds, spt_entries) <- {-# SCC "CorePrep" #-}
       liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
 
     (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
@@ -2003,7 +2007,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
     liftIO $ loadDecls interp hsc_env (src_span, Nothing) cbc
 
     {- Load static pointer table entries -}
-    liftIO $ hscAddSptEntries hsc_env Nothing (cg_spt_entries tidy_cg)
+    liftIO $ hscAddSptEntries hsc_env Nothing spt_entries
 
     let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
         patsyns = mg_patsyns simpl_mg
@@ -2160,8 +2164,9 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
            {- Tidy it (temporary, until coreSat does cloning) -}
          ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
 
+         ; let ictxt = hsc_IC hsc_env
            {- Prepare for codegen -}
-         ; prepd_expr <- corePrepExpr hsc_env tidy_expr
+         ; prepd_expr <- corePrepExpr hsc_env (icInteractiveModule ictxt) tidy_expr
 
            {- Lint if necessary -}
          ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr
@@ -2170,7 +2175,6 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
                                       ml_obj_file  = panic "hscCompileCoreExpr':ml_obj_file",
                                       ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file" }
 
-         ; let ictxt = hsc_IC hsc_env
          ; (stg_expr, _, _) <-
              myCoreToStgExpr (hsc_logger hsc_env)
                              (hsc_dflags hsc_env)
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index a9bcdeecc6..dc50aa4c29 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -387,18 +387,7 @@ tidyProgram hsc_env  (ModGuts { mg_module           = mod
                  <- tidyTopBinds uf_opts unfold_env tidy_occ_env trimmed_binds
 
           -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
-        ; (spt_entries, tidy_binds') <-
-             sptCreateStaticBinds hsc_env mod tidy_binds
-        ; let { platform = targetPlatform (hsc_dflags hsc_env)
-              ; spt_init_code = sptModuleInitCode platform mod spt_entries
-              ; add_spt_init_code =
-                  case backend dflags of
-                    -- If we are compiling for the interpreter we will insert
-                    -- any necessary SPT entries dynamically
-                    Interpreter -> id
-                    -- otherwise add a C stub to do so
-                    _              -> (`appendStubC` spt_init_code)
-
+        ; let {
               -- The completed type environment is gotten from
               --      a) the types and classes defined here (plus implicit things)
               --      b) adding Ids with correct IdInfo, including unfoldings,
@@ -423,7 +412,7 @@ tidyProgram hsc_env  (ModGuts { mg_module           = mod
               ; tidy_rules     = tidyRules tidy_env trimmed_rules
 
               ; -- See Note [Injecting implicit bindings]
-                all_tidy_binds = implicit_binds ++ tidy_binds'
+                all_tidy_binds = implicit_binds ++ tidy_binds
 
               -- Get the TyCons to generate code for.  Careful!  We must use
               -- the untidied TyCons here, because we need
@@ -467,12 +456,11 @@ tidyProgram hsc_env  (ModGuts { mg_module           = mod
                            cg_tycons   = alg_tycons,
                            cg_binds    = all_tidy_binds,
                            cg_ccs      = S.toList local_ccs,
-                           cg_foreign  = add_spt_init_code foreign_stubs,
+                           cg_foreign  = foreign_stubs,
                            cg_foreign_files = foreign_files,
                            cg_dep_pkgs = dep_direct_pkgs deps,
                            cg_hpc_info = hpc_info,
-                           cg_modBreaks = modBreaks,
-                           cg_spt_entries = spt_entries },
+                           cg_modBreaks = modBreaks },
 
                    ModDetails { md_types            = tidy_type_env,
                                 md_rules            = tidy_rules,
diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
index ad7c1a3ec8..833fd7e18c 100644
--- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
+++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
@@ -48,8 +48,7 @@
 --
 
 module GHC.Iface.Tidy.StaticPtrTable
-    ( sptCreateStaticBinds
-    , sptModuleInitCode
+    ( sptModuleInitCode
     ) where
 
 {- Note [Grand plan for static forms]
@@ -126,139 +125,19 @@ Here is a running example:
 import GHC.Prelude
 import GHC.Platform
 
-import GHC.Driver.Session
-import GHC.Driver.Env
 
-import GHC.Core
-import GHC.Core.Utils (collectMakeStaticArgs)
-import GHC.Core.DataCon
-import GHC.Core.Make (mkStringExprFSWith)
-import GHC.Core.Type
 
 import GHC.Cmm.CLabel
 
 import GHC.Unit.Module
 import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import GHC.Builtin.Names
-import GHC.Tc.Utils.Env (lookupGlobal)
 
 import GHC.Linker.Types
 
-import GHC.Types.Name
 import GHC.Types.Id
-import GHC.Types.TyThing
 import GHC.Types.ForeignStubs
 
-import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.State.Strict
-import Data.List (intercalate)
-import Data.Maybe
 import GHC.Fingerprint
-import qualified GHC.LanguageExtensions as LangExt
-
--- | Replaces all bindings of the form
---
--- > b = /\ ... -> makeStatic location value
---
---  with
---
--- > b = /\ ... ->
--- >   StaticPtr key (StaticPtrInfo "pkg key" "module" location) 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 ([SptEntry], CoreProgram)
-sptCreateStaticBinds hsc_env this_mod binds
-    | not (xopt LangExt.StaticPointers dflags) =
-      return ([], binds)
-    | otherwise = do
-      -- Make sure the required interface files are loaded.
-      _ <- lookupGlobal hsc_env unpackCStringName
-      (fps, binds') <- evalStateT (go [] [] binds) 0
-      return (fps, binds')
-  where
-    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'
-
-    dflags = hsc_dflags hsc_env
-    platform = targetPlatform dflags
-
-    -- 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 ([SptEntry], 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 SptEntry, (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 (SptEntry b fp), (b, foldr Lam e' tvs))
-
-    mkStaticBind :: Type -> CoreExpr -> CoreExpr
-                 -> StateT Int IO (Fingerprint, CoreExpr)
-    mkStaticBind t srcLoc e = do
-      i <- get
-      put (i + 1)
-      staticPtrInfoDataCon <-
-        lift $ lookupDataConHscEnv staticPtrInfoDataConName
-      let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i
-      info <- mkConApp staticPtrInfoDataCon <$>
-            (++[srcLoc]) <$>
-            mapM (mkStringExprFSWith (lift . lookupIdHscEnv))
-                 [ unitFS $ moduleUnit this_mod
-                 , moduleNameFS $ moduleName this_mod
-                 ]
-
-      -- The module interface of GHC.StaticPtr should be loaded at least
-      -- when looking up 'fromStatic' during type-checking.
-      staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName
-      return (fp, mkConApp staticPtrDataCon
-                               [ Type t
-                               , mkWord64LitWordRep platform w0
-                               , mkWord64LitWordRep platform w1
-                               , info
-                               , e ])
-
-    mkStaticPtrFingerprint :: Int -> Fingerprint
-    mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"
-        [ unitString $ moduleUnit this_mod
-        , moduleNameString $ moduleName this_mod
-        , show n
-        ]
-
-    -- Choose either 'Word64#' or 'Word#' to represent the arguments of the
-    -- 'Fingerprint' data constructor.
-    mkWord64LitWordRep platform =
-      case platformWordSize platform of
-        PW4 -> mkWord64LitWord64
-        PW8 -> mkWordLit platform . toInteger
-
-    lookupIdHscEnv :: Name -> IO Id
-    lookupIdHscEnv n = lookupType hsc_env n >>=
-                         maybe (getError n) (return . tyThingId)
-
-    lookupDataConHscEnv :: Name -> IO DataCon
-    lookupDataConHscEnv n = lookupType 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.
diff --git a/compiler/GHC/Types/Unique/Supply.hs b/compiler/GHC/Types/Unique/Supply.hs
index e2ecb16355..ad038fa3d6 100644
--- a/compiler/GHC/Types/Unique/Supply.hs
+++ b/compiler/GHC/Types/Unique/Supply.hs
@@ -45,6 +45,8 @@ import GHC.Exts( Ptr(..), noDuplicate#, oneShot )
 import GHC.Exts( Int(..), word2Int#, fetchAddWordAddr#, plusWord#, readWordOffAddr# )
 #endif
 import Foreign.Storable
+import Control.Monad.Trans.Writer
+import Control.Monad.Trans.Class
 
 #include "Unique.h"
 
@@ -375,6 +377,9 @@ instance MonadUnique UniqSM where
     getUniqueM  = getUniqueUs
     getUniquesM = getUniquesUs
 
+instance (Monoid w, MonadUnique m) => MonadUnique (WriterT w m)  where
+    getUniqueSupplyM = lift getUniqueSupplyM
+
 getUniqueUs :: UniqSM Unique
 getUniqueUs = mkUniqSM (\us0 -> case takeUniqFromSupply us0 of
                            (u,us1) -> UniqResult u us1)
diff --git a/compiler/GHC/Unit/Module/ModGuts.hs b/compiler/GHC/Unit/Module/ModGuts.hs
index e799ebf2a1..40ecee0d94 100644
--- a/compiler/GHC/Unit/Module/ModGuts.hs
+++ b/compiler/GHC/Unit/Module/ModGuts.hs
@@ -22,8 +22,6 @@ import GHC.Core         ( CoreProgram, CoreRule )
 import GHC.Core.TyCon
 import GHC.Core.PatSyn
 
-import GHC.Linker.Types ( SptEntry(..) )
-
 import GHC.Types.Annotations ( Annotation )
 import GHC.Types.Avail
 import GHC.Types.CompleteMatch
@@ -138,9 +136,5 @@ data CgGuts
         cg_dep_pkgs  :: ![UnitId], -- ^ Dependent packages, used to
                                             -- generate #includes for C code gen
         cg_hpc_info  :: !HpcInfo,           -- ^ Program coverage tick box information
-        cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints
-        cg_spt_entries :: [SptEntry]
-                -- ^ Static pointer table entries for static forms defined in
-                -- the module.
-                -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable"
+        cg_modBreaks :: !(Maybe ModBreaks) -- ^ Module breakpoints
     }