STG.Lift StaticPTr WIPwip/stg-lift-16981

Ticket #16981

12 files changed, 208 insertions, 178 deletions

diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index 3339842471..d8caee156c 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -5,9 +5,12 @@ Wired-in knowledge about {\em non-primitive} types
 -}
 
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
+#include "MachDeps.h"
+
 -- | This module is about types that can be defined in Haskell, but which
 --   must be wired into the compiler nonetheless.  C.f module "GHC.Builtin.Types.Prim"
 module GHC.Builtin.Types (
@@ -152,7 +155,11 @@ module GHC.Builtin.Types (
         integerINDataCon, integerINDataConName,
         naturalTy, naturalTyCon, naturalTyConName,
         naturalNSDataCon, naturalNSDataConName,
-        naturalNBDataCon, naturalNBDataConName
+        naturalNBDataCon, naturalNBDataConName,
+
+        -- * Static Pointers
+        staticPtrInfoTyCon, staticPtrInfoDataCon,
+        staticPtrDataCon, staticPtrTyCon
 
     ) where
 
@@ -2171,3 +2178,31 @@ filterCTuple (Exact n)
   | Just arity <- cTupleTyConNameArity_maybe n
   = Exact $ tupleTyConName BoxedTuple arity
 filterCTuple rdr = rdr
+
+staticPtrInfoDataCon :: DataCon
+staticPtrInfoDataCon = pcDataCon staticPtrInfoDataConName [] [stringTy, stringTy, mkBoxedTupleTy [intTy, intTy] ] staticPtrInfoTyCon
+
+staticPtrInfoTyCon :: TyCon
+staticPtrInfoTyCon = pcTyCon staticPtrInfoTyConName Nothing [] [staticPtrInfoDataCon]
+
+
+staticPtrDataCon :: DataCon
+
+staticPtrDataCon = pcDataCon staticPtrDataConName alpha_tyvar
+                      [ static_ptr_word_type
+                      , static_ptr_word_type
+                      , alphaTy
+                      , mkTyConTy staticPtrInfoTyCon]
+                      staticPtrTyCon
+  where
+    static_ptr_word_type =
+#if WORD_SIZE_IN_BITS < 64
+        word64PrimTy
+#else
+        wordPrimTy
+#endif
+
+
+
+staticPtrTyCon :: TyCon
+staticPtrTyCon = pcTyCon staticPtrTyConName Nothing [alphaTyVar] [staticPtrDataCon]
\ No newline at end of file
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 3b3a7232c0..5a547a180a 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -715,6 +715,7 @@ lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go
     go AllowAtTopLevel
       | (binders0, rhs') <- collectTyBinders rhs
       , Just (fun, t, info, e) <- collectMakeStaticArgs rhs'
+      , False
       = markAllJoinsBad $
         foldr
         -- imitate @lintCoreExpr (Lam ...)@
@@ -983,7 +984,7 @@ lintIdOcc var nargs
           -- Check for a nested occurrence of the StaticPtr constructor.
           -- See Note [Checking StaticPtrs].
         ; lf <- getLintFlags
-        ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $
+        ; when (False && nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $
             checkL (idName var /= makeStaticName) $
               text "Found makeStatic nested in an expression"
 
diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs
index 2d69e8eb04..6a6ba8757f 100644
--- a/compiler/GHC/Core/Opt/SetLevels.hs
+++ b/compiler/GHC/Core/Opt/SetLevels.hs
@@ -83,8 +83,7 @@ import GHC.Core.Utils   ( exprType, exprIsHNF
                         , exprOkForSpeculation
                         , exprIsTopLevelBindable
                         , isExprLevPoly
-                        , collectMakeStaticArgs
-                        , mkLamTypes
+                        , mkLamTypes, collectMakeStaticArgs
                         )
 import GHC.Core.Opt.Arity   ( exprBotStrictness_maybe )
 import GHC.Core.FVs     -- all of it
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 6b88262ff5..99f35df5aa 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -1315,7 +1315,7 @@ piResultTy_maybe ty arg = case coreFullView ty of
 -- so we pay attention to efficiency, especially in the special case
 -- where there are no for-alls so we are just dropping arrows from
 -- a function type/kind.
-piResultTys :: HasDebugCallStack => Type -> [Type] -> Type
+piResultTys :: HasCallStack => Type -> [Type] -> Type
 piResultTys ty [] = ty
 piResultTys ty orig_args@(arg:args)
   | FunTy { ft_res = res } <- ty
@@ -2245,7 +2245,7 @@ buildSynTyCon name binders res_kind roles rhs
 -- if it is surely unlifted, Nothing if we can't be sure (i.e., it is
 -- representation-polymorphic), and panics if the kind does not have the shape
 -- TYPE r.
-isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool
+isLiftedType_maybe :: HasCallStack => Type -> Maybe Bool
 isLiftedType_maybe ty = case coreFullView (getRuntimeRep ty) of
   ty' | isLiftedRuntimeRep ty'  -> Just True
   TyConApp {}                   -> Just False  -- Everything else is unlifted
@@ -2255,7 +2255,7 @@ isLiftedType_maybe ty = case coreFullView (getRuntimeRep ty) of
 -- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for
 -- a more approximate predicate that behaves better in the presence of
 -- representation polymorphism.
-isUnliftedType :: HasDebugCallStack => Type -> Bool
+isUnliftedType :: HasCallStack => Type -> Bool
         -- isUnliftedType returns True for forall'd unlifted types:
         --      x :: forall a. Int#
         -- I found bindings like these were getting floated to the top level.
@@ -2299,13 +2299,13 @@ dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy
 -- | Extract the RuntimeRep classifier of a type. For instance,
 -- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not
 -- possible.
-getRuntimeRep_maybe :: HasDebugCallStack
+getRuntimeRep_maybe :: HasCallStack
                     => Type -> Maybe Type
 getRuntimeRep_maybe = kindRep_maybe . typeKind
 
 -- | Extract the RuntimeRep classifier of a type. For instance,
 -- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible.
-getRuntimeRep :: HasDebugCallStack => Type -> Type
+getRuntimeRep :: HasCallStack => Type -> Type
 getRuntimeRep ty
   = case getRuntimeRep_maybe ty of
       Just r  -> r
@@ -2771,7 +2771,7 @@ See #14939.
 -}
 
 -----------------------------
-typeKind :: HasDebugCallStack => Type -> Kind
+typeKind :: HasCallStack => Type -> Kind
 -- No need to expand synonyms
 typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys
 typeKind (LitTy l)         = typeLiteralKind l
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index ea3040c64e..3bd93ac1ea 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -235,6 +235,9 @@ import Data.Functor
 import Control.DeepSeq (force)
 import Data.Bifunctor (first)
 import GHC.Data.Maybe
+import GHC.LanguageExtensions
+import GHC.Iface.Tidy.StaticPtrTable
+import GHC.Utils.Trace
 
 {- **********************************************************************
 %*                                                                      *
@@ -1550,16 +1553,20 @@ hscGenHardCode hsc_env cgguts location output_filename = do
                                    core_binds data_tycons
 
         -----------------  Convert to STG ------------------
-        (stg_binds, denv, (caf_ccs, caf_cc_stacks))
+        (stg_binds, spt_entries, denv, (caf_ccs, caf_cc_stacks))
             <- {-# SCC "CoreToStg" #-}
                withTiming logger
                    (text "CoreToStg"<+>brackets (ppr this_mod))
-                   (\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ())
+                   (\(a, b, c, (d,e)) -> a `seqList` b `seqList` c `seq` d `seqList` e `seqList` ())
                    (myCoreToStg logger dflags (hsc_IC hsc_env) False this_mod location prepd_binds)
-
+        pprTraceM "main" (ppr spt_entries)
         let cost_centre_info =
               (local_ccs ++ caf_ccs, caf_cc_stacks)
             platform = targetPlatform dflags
+
+            spt_init_code
+              | xopt StaticPointers dflags = sptModuleInitCode platform this_mod spt_entries
+              | otherwise = mempty
             prof_init
               | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info
               | otherwise = mempty
@@ -1592,6 +1599,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" #-}
@@ -1614,8 +1622,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,
@@ -1627,7 +1635,7 @@ hscInteractive hsc_env cgguts location = do
     prepd_binds <- {-# SCC "CorePrep" #-}
                    corePrepPgm hsc_env this_mod location core_binds data_tycons
 
-    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
+    (stg_binds, spt_entries, _infotable_prov, _caf_ccs__caf_cc_stacks)
       <- {-# SCC "CoreToStg" #-}
           myCoreToStg logger dflags (hsc_IC hsc_env) True this_mod location prepd_binds
     -----------------  Generate byte code ------------------
@@ -1784,7 +1792,7 @@ myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do
                                 (mkPseudoUniqueE 0)
                                 Many
                                 (exprType prepd_expr)
-    (stg_binds, prov_map, collected_ccs) <-
+    (stg_binds, _spt_entries, prov_map, collected_ccs) <-
        myCoreToStg logger
                    dflags
                    ictxt
@@ -1798,6 +1806,7 @@ myCoreToStg :: Logger -> DynFlags -> InteractiveContext
             -> Bool
             -> Module -> ModLocation -> CoreProgram
             -> IO ( [StgTopBinding] -- output program
+                  , [SptEntry]
                   , InfoTableProvMap
                   , CollectedCCs )  -- CAF cost centre info (declared and used)
 myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
@@ -1805,11 +1814,11 @@ myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
          = {-# SCC "Core2Stg" #-}
            coreToStg dflags this_mod ml prepd_binds
 
-    stg_binds2
+    (stg_binds2, spt_entries)
         <- {-# SCC "Stg2Stg" #-}
            stg2stg logger dflags ictxt for_bytecode this_mod stg_binds
 
-    return (stg_binds2, denv, cost_centre_info)
+    return (stg_binds2, spt_entries, denv, cost_centre_info)
 
 {- **********************************************************************
 %*                                                                      *
@@ -1948,7 +1957,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
     prepd_binds <- {-# SCC "CorePrep" #-}
       liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
 
-    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
+    (stg_binds, spt_entries, _infotable_prov, _caf_ccs__caf_cc_stacks)
         <- {-# SCC "CoreToStg" #-}
            liftIO $ myCoreToStg (hsc_logger hsc_env)
                                 (hsc_dflags hsc_env)
@@ -1966,7 +1975,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
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index 41b1ad6b9e..3b46feac70 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -17,7 +17,6 @@ module GHC.Iface.Tidy (
 import GHC.Prelude
 
 import GHC.Driver.Session
-import GHC.Driver.Backend
 import GHC.Driver.Ppr
 import GHC.Driver.Env
 
@@ -41,7 +40,6 @@ import GHC.Core.DataCon
 import GHC.Core.TyCon
 import GHC.Core.Class
 
-import GHC.Iface.Tidy.StaticPtrTable
 import GHC.Iface.Env
 
 import GHC.Utils.Outputable
@@ -51,7 +49,6 @@ import GHC.Utils.Trace
 import GHC.Utils.Logger as Logger
 import qualified GHC.Utils.Error as Err
 
-import GHC.Types.ForeignStubs
 import GHC.Types.Var.Env
 import GHC.Types.Var.Set
 import GHC.Types.Var
@@ -386,19 +383,7 @@ tidyProgram hsc_env  (ModGuts { mg_module           = mod
         ; (tidy_env, tidy_binds)
                  <- 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 +408,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 +452,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..b6d2af1445 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,36 +125,18 @@ 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
+import GHC.Utils.Trace
 
 -- | Replaces all bindings of the form
 --
@@ -170,95 +151,6 @@ import qualified GHC.LanguageExtensions as LangExt
 --
 -- 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.
@@ -267,7 +159,7 @@ sptCreateStaticBinds hsc_env this_mod binds
 -- its fingerprint.
 sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub
 sptModuleInitCode _        _        [] = mempty
-sptModuleInitCode platform this_mod entries = CStub $ vcat
+sptModuleInitCode platform this_mod entries = CStub $ pprTraceIt "init" $ 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)"
diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs
index f83ccd388f..b3cb8f28ea 100644
--- a/compiler/GHC/Stg/Lift.hs
+++ b/compiler/GHC/Stg/Lift.hs
@@ -30,6 +30,10 @@ import GHC.Utils.Panic
 import GHC.Types.Var.Set
 import Control.Monad ( when )
 import Data.Maybe ( isNothing )
+import GHC.Utils.Trace
+import GHC.Builtin.Names
+import GHC.Unit.Module
+import GHC.Linker.Types
 
 -- Note [Late lambda lifting in STG]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -124,8 +128,8 @@ import Data.Maybe ( isNothing )
 --
 -- (Mostly) textbook instance of the lambda lifting transformation, selecting
 -- which bindings to lambda lift by consulting 'goodToLift'.
-stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]
-stgLiftLams dflags us = runLiftM dflags us . foldr liftTopLvl (pure ())
+stgLiftLams :: Module -> DynFlags -> UniqSupply -> [InStgTopBinding] -> ([OutStgTopBinding], [SptEntry])
+stgLiftLams this_mod dflags us = runLiftM this_mod dflags us . foldr liftTopLvl (pure ())
 
 liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM ()
 liftTopLvl (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do
@@ -180,6 +184,7 @@ withLiftedBindPairs top rec pairs scope k = do
       when (isRec rec) startBindingGroup
       rhss' <- traverse (liftRhs (Just abs_ids)) rhss
       let pairs' = zip bndrs' rhss'
+      pprTraceM "LIFTING" (ppr bndrs)
       addLiftedBinding (mkStgBinding rec pairs')
       when (isRec rec) endBindingGroup
       k Nothing
@@ -220,6 +225,12 @@ liftArgs (StgVarArg occ) = do
 liftExpr :: LlStgExpr -> LiftM OutStgExpr
 liftExpr (StgLit lit) = pure (StgLit lit)
 liftExpr (StgTick t e) = StgTick t <$> liftExpr e
+liftExpr (StgApp f args)
+  | idName f == makeStaticName
+  , [cc_info, payload] <- args = do
+  cc_info' <- liftArgs cc_info
+  payload' <- liftArgs payload
+  addStaticPtrBinding cc_info' payload'
 liftExpr (StgApp f args) = do
   f' <- substOcc f
   args' <- traverse liftArgs args
diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs
index 5999104c9c..05f704e965 100644
--- a/compiler/GHC/Stg/Lift/Analysis.hs
+++ b/compiler/GHC/Stg/Lift/Analysis.hs
@@ -38,6 +38,7 @@ import GHC.Utils.Misc
 import GHC.Types.Var.Set
 
 import Data.Maybe ( mapMaybe )
+import GHC.Utils.Trace
 
 -- Note [When to lift]
 -- ~~~~~~~~~~~~~~~~~~~
@@ -107,8 +108,8 @@ import Data.Maybe ( mapMaybe )
 -- <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>.
 
 llTrace :: String -> SDoc -> a -> a
-llTrace _ _ c = c
--- llTrace a b c = pprTrace a b c
+--llTrace _ _ c = c
+llTrace a b c = pprTrace a b c
 
 type instance BinderP      'LiftLams = BinderInfo
 type instance XRhsClosure  'LiftLams = DIdSet
@@ -467,6 +468,11 @@ goodToLift dflags top_lvl rec_flag expander pairs scope = decide
         $ freeVarsOfRhs rhs
       clo_growth = closureGrowth expander (idClosureFootprint platform) bndrs_set abs_ids scope
 
+
+      is_static_rhs = case rhss of
+                        [StgRhsClosure _ _ _ binders body] -> pprTrace "is_static" (ppr binders $$ pprStgExpr shortStgPprOpts body) False
+                        _ -> pprTrace "rhs" (vcat (map (pprStgRhs shortStgPprOpts) rhss)) False
+
 rhsLambdaBndrs :: LlStgRhs -> [Id]
 rhsLambdaBndrs StgRhsCon{} = []
 rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _) = map binderInfoBndr bndrs
diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs
index 9b29b02ba6..6110e3b809 100644
--- a/compiler/GHC/Stg/Lift/Monad.hs
+++ b/compiler/GHC/Stg/Lift/Monad.hs
@@ -13,7 +13,7 @@ module GHC.Stg.Lift.Monad (
     -- * Transformation monad
     LiftM, runLiftM,
     -- ** Adding bindings
-    startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding,
+    startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding, addStaticPtrBinding,
     -- ** Substitution and binders
     withSubstBndr, withSubstBndrs, withLiftedBndr, withLiftedBndrs,
     -- ** Occurrences
@@ -46,6 +46,19 @@ import Control.Monad.Trans.RWS.Strict ( RWST, runRWST )
 import qualified Control.Monad.Trans.RWS.Strict as RWS
 import Control.Monad.Trans.Cont ( ContT (..) )
 import Data.ByteString ( ByteString )
+import GHC.Core.TyCo.Rep
+import GHC.Core.Type
+import GHC.Builtin.Types
+import GHC.Linker.Types
+import GHC.Types.Unique
+import GHC.Fingerprint
+import GHC.Unit.Module
+import Data.List (intercalate)
+import GHC.Types.Literal
+import GHC.Platform
+import Data.Maybe
+import GHC.LanguageExtensions
+import GHC.Types.SrcLoc
 
 -- | @uncurry 'mkStgBinding' . 'decomposeStgBinding' = id@
 decomposeStgBinding :: GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)])
@@ -80,10 +93,11 @@ data Env
   -- 'InId's to 'OutId's.
   --
   -- Invariant: 'Id's not present in this map won't be substituted.
+  , e_mod :: !Module
   }
 
-emptyEnv :: DynFlags -> Env
-emptyEnv dflags = Env dflags emptySubst emptyVarEnv
+emptyEnv :: Module -> DynFlags -> Env
+emptyEnv this_mod dflags = Env dflags emptySubst emptyVarEnv this_mod
 
 
 -- Note [Handling floats]
@@ -145,6 +159,7 @@ data FloatLang
   | EndBindingGroup
   | PlainTopBinding OutStgTopBinding
   | LiftedBinding OutStgBinding
+  | LiftedStaticBinding SptEntry Id StgRhs
 
 instance Outputable FloatLang where
   ppr StartBindingGroup = char '('
@@ -154,10 +169,11 @@ instance Outputable FloatLang where
   ppr (LiftedBinding bind) = (if isRec rec then char 'r' else char 'n') <+> ppr (map fst pairs)
     where
       (rec, pairs) = decomposeStgBinding bind
+  ppr (LiftedStaticBinding _spt binder _bind) = ppr binder
 
 -- | Flattens an expression in @['FloatLang']@ into an STG program, see "GHC.Stg.Lift.Monad#floats".
--- Important pre-conditions: The nesting of opening 'StartBindinGroup's and
--- closing 'EndBindinGroup's is balanced. Also, it is crucial that every binding
+-- Important pre-conditions: The nesting of opening 'StartBindingGroup's and
+-- closing 'EndBindingGroup's is balanced. Also, it is crucial that every binding
 -- group has at least one recursive binding inside. Otherwise there's no point
 -- in announcing the binding group in the first place and an @ASSERT@ will
 -- trigger.
@@ -178,6 +194,9 @@ collectFloats = go (0 :: Int) []
       LiftedBinding bind
         | n == 0 -> StgTopLifted (rm_cccs bind) : go n binds rest
         | otherwise -> go n (bind:binds) rest
+      LiftedStaticBinding _ binder bind
+        | n == 0 -> StgTopLifted (StgNonRec binder bind) : go n binds rest
+        | otherwise -> go n (StgNonRec binder bind : binds) rest
 
     map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding
     rm_cccs = map_rhss removeRhsCCCS
@@ -186,6 +205,12 @@ collectFloats = go (0 :: Int) []
     is_rec StgRec{} = True
     is_rec _ = False
 
+collectSPTEntries :: [FloatLang] -> [SptEntry]
+collectSPTEntries = mapMaybe go
+  where
+    go (LiftedStaticBinding spt_entry _ _) = Just spt_entry
+    go _ = Nothing
+
 -- | Omitting this makes for strange closure allocation schemes that crash the
 -- GC.
 removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass
@@ -222,10 +247,14 @@ instance MonadUnique LiftM where
   getUniqueM = LiftM (lift getUniqueM)
   getUniquesM = LiftM (lift getUniquesM)
 
-runLiftM :: DynFlags -> UniqSupply -> LiftM () -> [OutStgTopBinding]
-runLiftM dflags us (LiftM m) = collectFloats (fromOL floats)
+runLiftM :: Module -> DynFlags -> UniqSupply -> LiftM () -> ([OutStgTopBinding], [SptEntry])
+runLiftM this_mod dflags us (LiftM m) = (collectFloats (fromOL floats), spt_entries)
   where
-    (_, _, floats) = initUs_ us (runRWST m (emptyEnv dflags) ())
+    spt_entries
+      | xopt StaticPointers dflags = collectSPTEntries final_floats
+      | otherwise = []
+    final_floats = fromOL floats
+    (_, _, floats) = initUs_ us (runRWST m (emptyEnv this_mod dflags) ())
 
 -- | Writes a plain 'StgTopStringLit' to the output.
 addTopStringLit :: OutId -> ByteString -> LiftM ()
@@ -245,6 +274,61 @@ endBindingGroup = LiftM $ RWS.tell $ unitOL $ EndBindingGroup
 addLiftedBinding :: OutStgBinding -> LiftM ()
 addLiftedBinding = LiftM . RWS.tell . unitOL . LiftedBinding
 
+addLiftedStaticPtrBinding :: SptEntry -> Id -> StgRhs -> LiftM ()
+addLiftedStaticPtrBinding spt_entry binder bind =
+  LiftM . RWS.tell . unitOL $ LiftedStaticBinding spt_entry binder bind
+
+newStaticPtrBndr :: Unique -> Module -> Type -> Id
+newStaticPtrBndr uniq this_mod ty =
+  let str = "$static_ptr" ++ show uniq
+  in mkVanillaGlobal
+        -- This makes and external name but *doesn't* add it to the name cache,
+        -- this is safe because the name is only, and can only be, referenced from the
+        -- SPT init stub.
+        (mkExternalName uniq this_mod (mkVarOcc str) noSrcSpan)
+        (mkTyConApp staticPtrTyCon [ty])
+
+addStaticPtrBinding :: StgArg -> StgArg -> LiftM StgExpr
+addStaticPtrBinding loc payload = do
+  uniq <- getUniqueM
+  uniq_info <- getUniqueM
+  this_mod <- LiftM $ RWS.asks e_mod
+  platform <- targetPlatform <$> (LiftM $ RWS.asks e_dflags)
+  let binder_ptr = newStaticPtrBndr uniq this_mod (stgArgType payload)
+      binder_info = mkSysLocal (mkFastString "$static_ptr_info") uniq_info Many (mkTyConTy staticPtrInfoTyCon)
+      fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint this_mod uniq
+      unit_lit = LitString (bytesFS $ unitFS $ moduleUnit this_mod)
+      mod_name_lit = LitString (bytesFS $ moduleNameFS $ moduleName this_mod)
+
+      info = StgRhsCon dontCareCCS staticPtrInfoDataCon NoNumber [] [StgLitArg unit_lit, StgLitArg mod_name_lit, loc]
+
+      ptr = StgRhsCon dontCareCCS staticPtrDataCon NoNumber []
+              [ StgLitArg (mkWord64LitWordRep platform (toInteger w0))
+              , StgLitArg (mkWord64LitWordRep platform (toInteger w1))
+              , StgVarArg binder_info
+              , payload]
+
+      spt_entry = SptEntry binder_ptr fp
+  addLiftedBinding (StgNonRec binder_info info)
+  addLiftedStaticPtrBinding spt_entry binder_ptr ptr
+  return (StgApp binder_ptr [])
+
+  where
+    mkStaticPtrFingerprint :: Module -> Unique -> Fingerprint
+    mkStaticPtrFingerprint this_mod 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 -> Integer -> Literal
+    mkWord64LitWordRep platform =
+      case platformWordSize platform of
+        PW4 -> mkLitWord64
+        PW8 -> mkLitWord platform . toInteger
+
 -- | Takes a binder and a continuation which is called with the substituted
 -- binder. The continuation will be evaluated in a 'LiftM' context in which that
 -- binder is deemed in scope. Think of it as a 'RWS.local' computation: After
@@ -283,6 +367,8 @@ withLiftedBndr abs_ids bndr inner = do
       })
     (unwrapLiftM (inner bndr'))
 
+-- | Create a new exported vanilla id for the static pointer
+
 -- | See 'withLiftedBndr'.
 withLiftedBndrs :: Traversable f => DIdSet -> f Id -> (f Id -> LiftM a) -> LiftM a
 withLiftedBndrs abs_ids = runContT . traverse (ContT . withLiftedBndr abs_ids)
diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs
index b0e1848f19..40ac929c42 100644
--- a/compiler/GHC/Stg/Pipeline.hs
+++ b/compiler/GHC/Stg/Pipeline.hs
@@ -33,6 +33,10 @@ import GHC.Utils.Logger
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Reader
+import GHC.Utils.Trace
+import GHC.Linker.Types
+import Data.IORef
+import GHC.LanguageExtensions
 
 newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
   deriving (Functor, Applicative, Monad, MonadIO)
@@ -52,13 +56,14 @@ stg2stg :: Logger
         -> Bool                      -- prepare for bytecode?
         -> Module                    -- module being compiled
         -> [StgTopBinding]           -- input program
-        -> IO [StgTopBinding]        -- output program
+        -> IO ([StgTopBinding], [SptEntry])        -- output program
 stg2stg logger dflags ictxt for_bytecode this_mod binds
   = do  { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds
         ; showPass logger "Stg2Stg"
+        ; spt_entries_var <- newIORef []
         -- Do the main business!
         ; binds' <- runStgM 'g' $
-            foldM do_stg_pass binds (getStgToDo for_bytecode dflags)
+            foldM (do_stg_pass spt_entries_var) binds (getStgToDo for_bytecode dflags)
 
           -- Dependency sort the program as last thing. The program needs to be
           -- in dependency order for the SRT algorithm to work (see
@@ -69,7 +74,8 @@ stg2stg logger dflags ictxt for_bytecode this_mod binds
           -- preserve the order or only create minimal recursive groups, so a
           -- sorting pass is necessary.
         ; let binds_sorted = depSortStgPgm this_mod binds'
-        ; return binds_sorted
+        ; spt_entries <- readIORef spt_entries_var
+        ; return (binds_sorted, spt_entries)
    }
 
   where
@@ -80,8 +86,8 @@ stg2stg logger dflags ictxt for_bytecode this_mod binds
       = \ _whodunnit _binds -> return ()
 
     -------------------------------------------
-    do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]
-    do_stg_pass binds to_do
+    do_stg_pass :: IORef [SptEntry] -> [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]
+    do_stg_pass spt_result binds to_do
       = case to_do of
           StgDoNothing ->
             return binds
@@ -94,8 +100,11 @@ stg2stg logger dflags ictxt for_bytecode this_mod binds
             end_pass "StgCse" binds'
 
           StgLiftLams -> do
+            pprTraceM "running lift" empty
             us <- getUniqueSupplyM
-            let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds
+            let (binds', spt_entries) = {-# SCC "StgLiftLams" #-} stgLiftLams this_mod dflags us binds
+            pprTraceM "spt_entries" (ppr spt_entries)
+            liftIO $ writeIORef spt_result spt_entries
             end_pass "StgLiftLams" binds'
 
           StgBcPrep -> do
@@ -149,11 +158,15 @@ getStgToDo for_bytecode dflags =
     -- Important that unarisation comes first
     -- See Note [StgCse after unarisation] in GHC.Stg.CSE
     , optional Opt_StgCSE StgCSE
-    , optional Opt_StgLiftLams StgLiftLams
+    , runWhen run_lift StgLiftLams
     , runWhen for_bytecode StgBcPrep
     , optional Opt_StgStats StgStats
     ] where
       optional opt = runWhen (gopt opt dflags)
+      -- The LiftLams pass lifts static forms to the top-level, this is necessary
+      -- for correctness so the pass is always run when StaticPointers is enabled.
+      -- See [Grand plan for static forms]
+      run_lift = gopt Opt_StgLiftLams dflags || xopt StaticPointers dflags
       mandatory = id
 
 runWhen :: Bool -> StgToDo -> StgToDo
diff --git a/compiler/GHC/Unit/Module/ModGuts.hs b/compiler/GHC/Unit/Module/ModGuts.hs
index e799ebf2a1..98c65bcb9a 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
     }