spt

5 files changed, 153 insertions, 51 deletions

diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 30c28a6db2..4ae5eae280 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,20 @@ 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.Name   ( NamedThing(..), nameSrcSpan, isInternalName, Name )
 import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
 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
 
 {-
 -- ---------------------------------------------------------------------------
@@ -237,42 +242,50 @@ 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
+        (binds_out, unzip->(spe_floats, spt_binds))
+                    = initUs_ us $ runWriterT $ do
                       floats1 <- corePrepTopBinds initialCorePrepEnv binds
                       floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
                       return (deFloatTop (floats1 `appendFloats` floats2))
 
     endPassIO hsc_env alwaysQualify CorePrep binds_out []
-    return binds_out
+    return (spt_binds ++ binds_out, spe_floats)
   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 +590,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 +657,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 +708,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 +735,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 +776,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 +893,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 +908,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 +959,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 +992,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 +1057,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
+          (fp, new_expr) <- cpe_mk_static_form env t1 loc arg
+          float_var <- newVar (exprType new_expr)
+          tell ([(SptEntry float_var fp, NonRec float_var new_expr)])
+          cpe_app env (Var float_var) rest n
+
+
+
 
     cpe_app env (Var v) args depth
       = do { v1 <- fiddleCCall v
@@ -1098,7 +1121,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 +1396,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 +1448,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 +1859,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 (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 +2010,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 +2069,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,7 +2078,7 @@ fiddleCCall id
 -- Generating new binders
 -- ---------------------------------------------------------------------------
 
-newVar :: Type -> UniqSM Id
+newVar :: Type -> CorePrepM Id
 newVar ty
  = seqType ty `seq` do
      uniq <- getUniqueM
@@ -2204,3 +2232,50 @@ mkConvertNumLiteral hsc_env = do
 
    return convertNumLit
 
+-- Static Forms
+
+mkMkStaticForm :: HscEnv -> Module -> IO (Type -> CoreExpr -> CoreExpr -> CorePrepM (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 key
+            info = mkConApp staticPtrInfoDataCon (fs ++ [srcLoc])
+
+        -- The module interface of GHC.StaticPtr should be loaded at least
+        -- when looking up 'fromStatic' during type-checking.
+        return (fp, mkConApp staticPtrDataCon
+                                 [ Type t
+                                 , mkWord64LitWordRep platform w0
+                                 , mkWord64LitWordRep platform w1
+                                 , info
+                                 , e ])
+
+  where
+    dflags = hsc_dflags hsc_env
+    platform = targetPlatform dflags
+
+    mkStaticPtrFingerprint :: Unique -> 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 3d55e77191..be8538e52a 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -1588,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
 
@@ -1607,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
@@ -1635,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" #-}
@@ -1657,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,
@@ -1667,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)
@@ -1984,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)
@@ -2004,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
@@ -2161,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
@@ -2171,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..c9c1a3eeed 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -467,7 +467,7 @@ 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,
diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
index ad7c1a3ec8..826d5feda4 100644
--- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
+++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
@@ -156,6 +156,11 @@ import Data.List (intercalate)
 import Data.Maybe
 import GHC.Fingerprint
 import qualified GHC.LanguageExtensions as LangExt
+import Data.Unique
+import GHC.Types.Name.Cache
+import GHC.Types.Id.Info
+import GHC.Types.SrcLoc
+import Control.Monad.IO.Class
 
 -- | Replaces all bindings of the form
 --
@@ -185,7 +190,8 @@ sptCreateStaticBinds hsc_env this_mod binds
       []        -> return (reverse fps, reverse bs)
       bnd : xs' -> do
         (fps', bnd') <- replaceStaticBind bnd
-        go (reverse fps' ++ fps) (bnd' : bs) xs'
+        let (spt_entries, alias_binds) = unzip fps'
+        go (reverse spt_entries ++ fps) (alias_binds ++ (bnd' : bs)) xs'
 
     dflags = hsc_dflags hsc_env
     platform = targetPlatform dflags
@@ -194,7 +200,7 @@ sptCreateStaticBinds hsc_env this_mod binds
     --
     -- The 'Int' state is used to produce a different key for each binding.
     replaceStaticBind :: CoreBind
-                      -> StateT Int IO ([SptEntry], CoreBind)
+                      -> StateT Int IO ([(SptEntry, CoreBind)], CoreBind)
     replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e
                                         return (maybeToList mfp, NonRec b' e')
     replaceStaticBind (Rec rbs) = do
@@ -202,21 +208,33 @@ sptCreateStaticBinds hsc_env this_mod binds
       return (catMaybes mfps, Rec rbs')
 
     replaceStatic :: Id -> CoreExpr
-                  -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr))
+                  -> StateT Int IO (Maybe (SptEntry, CoreBind), (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
+          (b', alias_bind, fp, e') <- mkStaticBind b t info arg
+          return (Just ((SptEntry b' fp), alias_bind), (b, foldr Lam e' tvs))
+
+    -- Clone the
+    cloneStaticId :: Int -> Id -> IO (Id, CoreBind)
+    cloneStaticId n static_id = do
+      let cloned_occname = mkVarOcc ("$static_key" ++ show n)
+          name_cache = hsc_NC hsc_env
+      unique <-  takeUniqFromNameCache name_cache
+      let cloned_name = mkExternalName unique this_mod cloned_occname noSrcSpan
+          cloned_id   = mkGlobalId VanillaId cloned_name (idType static_id) vanillaIdInfo
+          alias_bind = NonRec cloned_id (Var static_id)
+      return (cloned_id, alias_bind)
+
+    mkStaticBind :: Id -> Type -> CoreExpr -> CoreExpr
+                 -> StateT Int IO (Id, CoreBind, Fingerprint, CoreExpr)
+    mkStaticBind old_id t srcLoc e = do
       i <- get
       put (i + 1)
       staticPtrInfoDataCon <-
         lift $ lookupDataConHscEnv staticPtrInfoDataConName
+      (cloned_id, alias_bind) <- liftIO $ cloneStaticId i old_id
       let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i
       info <- mkConApp staticPtrInfoDataCon <$>
             (++[srcLoc]) <$>
@@ -228,7 +246,7 @@ sptCreateStaticBinds hsc_env this_mod binds
       -- 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
+      return (cloned_id, alias_bind, fp, mkConApp staticPtrDataCon
                                [ Type t
                                , mkWord64LitWordRep platform w0
                                , mkWord64LitWordRep platform w1
@@ -260,6 +278,7 @@ sptCreateStaticBinds hsc_env this_mod binds
     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)