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

4 files changed, 34 insertions, 1 deletions

diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index fe4e95eb9e..c336349daf 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -30,6 +30,7 @@ import GHCi.TH.Binary ()
 import GHCi.BreakArray
 
 import GHC.LanguageExtensions
+import GHC.Fingerprint
 import Control.Concurrent
 import Control.Exception
 import Data.Binary
@@ -85,6 +86,9 @@ data Message a where
   -- | Release 'HValueRef's
   FreeHValueRefs :: [HValueRef] -> Message ()
 
+  -- | Add entries to the Static Pointer Table
+  AddSptEntry :: Fingerprint -> HValueRef -> Message ()
+
   -- | Malloc some data and return a 'RemotePtr' to it
   MallocData :: ByteString -> Message (RemotePtr ())
   MallocStrings :: [ByteString] -> Message [RemotePtr ()]
@@ -446,6 +450,7 @@ getMessage = do
       30 -> Msg <$> (GetBreakpointVar <$> get <*> get)
       31 -> Msg <$> return StartTH
       32 -> Msg <$> (RunModFinalizers <$> get <*> get)
+      33 -> Msg <$> (AddSptEntry <$> get <*> get)
       _  -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
 
 putMessage :: Message a -> Put
@@ -483,7 +488,8 @@ putMessage m = case m of
   GetBreakpointVar a b        -> putWord8 30 >> put a >> put b
   StartTH                     -> putWord8 31
   RunModFinalizers a b        -> putWord8 32 >> put a >> put b
-  RunTH st q loc ty           -> putWord8 33 >> put st >> put q >> put loc >> put ty
+  AddSptEntry a b             -> putWord8 33 >> put a >> put b
+  RunTH st q loc ty           -> putWord8 34 >> put st >> put q >> put loc >> put ty
 
 -- -----------------------------------------------------------------------------
 -- Reading/writing messages
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
index 858b247f65..eecafa1f75 100644
--- a/libraries/ghci/GHCi/Run.hs
+++ b/libraries/ghci/GHCi/Run.hs
@@ -20,6 +20,7 @@ import GHCi.ObjLink
 import GHCi.RemoteTypes
 import GHCi.TH
 import GHCi.BreakArray
+import GHCi.StaticPtrTable
 
 import Control.Concurrent
 import Control.DeepSeq
@@ -56,6 +57,7 @@ run m = case m of
   FindSystemLibrary str -> findSystemLibrary str
   CreateBCOs bcos -> createBCOs (concatMap (runGet get) bcos)
   FreeHValueRefs rs -> mapM_ freeRemoteRef rs
+  AddSptEntry fpr r -> localRef r >>= sptAddEntry fpr
   EvalStmt opts r -> evalStmt opts r
   ResumeStmt opts r -> resumeStmt opts r
   AbandonStmt r -> abandonStmt r
diff --git a/libraries/ghci/GHCi/StaticPtrTable.hs b/libraries/ghci/GHCi/StaticPtrTable.hs
new file mode 100644
index 0000000000..d23e810f8a
--- /dev/null
+++ b/libraries/ghci/GHCi/StaticPtrTable.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module GHCi.StaticPtrTable ( sptAddEntry ) where
+
+import Data.Word
+import Foreign
+import GHC.Fingerprint
+import GHCi.RemoteTypes
+
+-- | Used by GHCi to add an SPT entry for a set of interactive bindings.
+sptAddEntry :: Fingerprint -> HValue -> IO ()
+sptAddEntry (Fingerprint a b) (HValue x) = do
+    -- We own the memory holding the key (fingerprint) which gets inserted into
+    -- the static pointer table and can't free it until the SPT entry is removed
+    -- (which is currently never).
+    fpr_ptr <- newArray [a,b]
+    sptr <- newStablePtr x
+    ent_ptr <- malloc
+    poke ent_ptr (castStablePtrToPtr sptr)
+    spt_insert_stableptr fpr_ptr ent_ptr
+
+foreign import ccall "hs_spt_insert_stableptr"
+    spt_insert_stableptr :: Ptr Word64 -> Ptr (Ptr ()) -> IO ()
diff --git a/libraries/ghci/ghci.cabal.in b/libraries/ghci/ghci.cabal.in
index 87b2c4e2fd..631eed7190 100644
--- a/libraries/ghci/ghci.cabal.in
+++ b/libraries/ghci/ghci.cabal.in
@@ -62,6 +62,7 @@ library
         GHCi.RemoteTypes
         GHCi.FFI
         GHCi.InfoTable
+        GHCi.StaticPtrTable
         GHCi.TH.Binary
         SizedSeq