Add support for StaticPointers in GHCi

Here we add support to GHCi for StaticPointers. This process begins by
adding remote GHCi messages for adding entries to the static pointer
table. We then collect binders needing SPT entries after linking and
send the interpreter a message adding entries with the appropriate
fingerprints.

Test Plan: `make test TEST=StaticPtr`

Reviewers: facundominguez, mboes, simonpj, simonmar, goldfire, austin,
hvr, erikd

Reviewed By: simonpj, simonmar

Subscribers: RyanGlScott, simonpj, thomie

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

GHC Trac Issues: #12356

1 files changed, 23 insertions, 15 deletions

diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs
index 7a836e6068..f61714db61 100644
--- a/compiler/main/StaticPtrTable.hs
+++ b/compiler/main/StaticPtrTable.hs
@@ -45,8 +45,11 @@
 -- > }
 --
 
-{-# LANGUAGE ViewPatterns #-}
-module StaticPtrTable (sptCreateStaticBinds) where
+{-# LANGUAGE ViewPatterns, TupleSections #-}
+module StaticPtrTable
+    ( sptCreateStaticBinds
+    , sptModuleInitCode
+    ) where
 
 {- Note [Grand plan for static forms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -114,10 +117,15 @@ Here is a running example:
 
   where a distinct key is generated for each binding.
 
-  We produce also a C function which inserts all these bindings in the static
-  pointer table (see the call to StaticPtrTable.sptCreateStaticBinds in
-  TidyPgm). As the Ids of floated static pointers are exported, they can be
-  linked with the C function.
+* If we are compiling to object code we insert a C stub (generated by
+  sptModuleInitCode) into the final object which runs when the module is loaded,
+  inserting the static forms defined by the module into the RTS's static pointer
+  table.
+
+* If we are compiling for the byte-code interpreter, we instead explicitly add
+  the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter
+  process' SPT table using the addSptEntry interpreter message. This happens
+  in upsweep after we have compiled the module (see GhcMake.upsweep').
 -}
 
 import CLabel
@@ -157,15 +165,15 @@ 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 (SDoc, CoreProgram)
+                     -> IO ([SptEntry], CoreProgram)
 sptCreateStaticBinds hsc_env this_mod binds
     | not (xopt LangExt.StaticPointers dflags) =
-      return (Outputable.empty, binds)
+      return ([], binds)
     | otherwise = do
       -- Make sure the required interface files are loaded.
       _ <- lookupGlobal hsc_env unpackCStringName
       (fps, binds') <- evalStateT (go [] [] binds) 0
-      return (sptModuleInitCode this_mod fps, binds')
+      return (fps, binds')
   where
     go fps bs xs = case xs of
       []        -> return (reverse fps, reverse bs)
@@ -179,7 +187,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 ([(Id, Fingerprint)], 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
@@ -187,13 +195,13 @@ sptCreateStaticBinds hsc_env this_mod binds
       return (catMaybes mfps, Rec rbs')
 
     replaceStatic :: Id -> CoreExpr
-                  -> StateT Int IO (Maybe (Id, Fingerprint), (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 (b, fp), (b, foldr Lam e' tvs))
+          return (Just (SptEntry b fp), (b, foldr Lam e' tvs))
 
     mkStaticBind :: Type -> CoreExpr -> CoreExpr
                  -> StateT Int IO (Fingerprint, CoreExpr)
@@ -249,7 +257,7 @@ sptCreateStaticBinds hsc_env this_mod binds
 --
 -- @fps@ is a list associating each binding corresponding to a static entry with
 -- its fingerprint.
-sptModuleInitCode :: Module -> [(Id, Fingerprint)] -> SDoc
+sptModuleInitCode :: Module -> [SptEntry] -> SDoc
 sptModuleInitCode _ [] = Outputable.empty
 sptModuleInitCode this_mod entries = vcat
     [ text "static void hs_spt_init_" <> ppr this_mod
@@ -267,7 +275,7 @@ sptModuleInitCode this_mod entries = vcat
                 ]
              )
         <> semi
-        |  (i, (n, fp)) <- zip [0..] entries
+        |  (i, SptEntry n fp) <- zip [0..] entries
         ]
     , text "static void hs_spt_fini_" <> ppr this_mod
            <> text "(void) __attribute__((destructor));"
@@ -276,7 +284,7 @@ sptModuleInitCode this_mod entries = vcat
         [  text "StgWord64 k" <> int i <> text "[2] = "
            <> pprFingerprint fp <> semi
         $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
-        | (i, (_, fp)) <- zip [0..] entries
+        | (i, (SptEntry _ fp)) <- zip [0..] entries
         ]
     ]
   where