A little closer to supporting breakpoints with -fexternal-interpreter

Summary: Moves getIdValFromApStack to the server, and removes one use of wormhole.

Test Plan: validate

Reviewers: bgamari, niteria, austin, hvr, erikd

Subscribers: thomie

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

GHC Trac Issues: #11100

2 files changed, 66 insertions, 44 deletions

diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 45b19514bc..a22767a3f7 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -152,6 +152,12 @@ data Message a where
    -> Int                               -- index
    -> Message Bool                      -- True <=> enabled
 
+  -- | Get a reference to a free variable at a breakpoint
+  GetBreakpointVar
+   :: HValueRef                         -- the AP_STACK from EvalBreak
+   -> Int
+   -> Message (Maybe HValueRef)
+
   -- Template Haskell -------------------------------------------
 
   -- | Start a new TH module, return a state token that should be
@@ -333,27 +339,28 @@ getMessage = do
       26 -> Msg <$> (NewBreakArray <$> get)
       27 -> Msg <$> (EnableBreakpoint <$> get <*> get <*> get)
       28 -> Msg <$> (BreakpointStatus <$> get <*> get)
-      29 -> Msg <$> return StartTH
-      30 -> Msg <$> FinishTH <$> get
-      31 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
-      32 -> Msg <$> NewName <$> get
-      33 -> Msg <$> (Report <$> get <*> get)
-      34 -> Msg <$> (LookupName <$> get <*> get)
-      35 -> Msg <$> Reify <$> get
-      36 -> Msg <$> ReifyFixity <$> get
-      37 -> Msg <$> (ReifyInstances <$> get <*> get)
-      38 -> Msg <$> ReifyRoles <$> get
-      39 -> Msg <$> (ReifyAnnotations <$> get <*> get)
-      40 -> Msg <$> ReifyModule <$> get
-      41 -> Msg <$> ReifyConStrictness <$> get
-      42 -> Msg <$> AddDependentFile <$> get
-      43 -> Msg <$> AddTopDecls <$> get
-      44 -> Msg <$> (IsExtEnabled <$> get)
-      45 -> Msg <$> return ExtsEnabled
-      46 -> Msg <$> return StartRecover
-      47 -> Msg <$> EndRecover <$> get
-      48 -> Msg <$> return QDone
-      49 -> Msg <$> QException <$> get
+      29 -> Msg <$> (GetBreakpointVar <$> get <*> get)
+      30 -> Msg <$> return StartTH
+      31 -> Msg <$> FinishTH <$> get
+      32 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
+      33 -> Msg <$> NewName <$> get
+      34 -> Msg <$> (Report <$> get <*> get)
+      35 -> Msg <$> (LookupName <$> get <*> get)
+      36 -> Msg <$> Reify <$> get
+      37 -> Msg <$> ReifyFixity <$> get
+      38 -> Msg <$> (ReifyInstances <$> get <*> get)
+      39 -> Msg <$> ReifyRoles <$> get
+      40 -> Msg <$> (ReifyAnnotations <$> get <*> get)
+      41 -> Msg <$> ReifyModule <$> get
+      42 -> Msg <$> ReifyConStrictness <$> get
+      43 -> Msg <$> AddDependentFile <$> get
+      44 -> Msg <$> AddTopDecls <$> get
+      45 -> Msg <$> (IsExtEnabled <$> get)
+      46 -> Msg <$> return ExtsEnabled
+      47 -> Msg <$> return StartRecover
+      48 -> Msg <$> EndRecover <$> get
+      49 -> Msg <$> return QDone
+      50 -> Msg <$> QException <$> get
       _  -> Msg <$> QFail <$> get
 
 putMessage :: Message a -> Put
@@ -387,28 +394,29 @@ putMessage m = case m of
   NewBreakArray sz            -> putWord8 26 >> put sz
   EnableBreakpoint arr ix b   -> putWord8 27 >> put arr >> put ix >> put b
   BreakpointStatus arr ix     -> putWord8 28 >> put arr >> put ix
-  StartTH                     -> putWord8 29
-  FinishTH val                -> putWord8 30 >> put val
-  RunTH st q loc ty           -> putWord8 31 >> put st >> put q >> put loc >> put ty
-  NewName a                   -> putWord8 32 >> put a
-  Report a b                  -> putWord8 33 >> put a >> put b
-  LookupName a b              -> putWord8 34 >> put a >> put b
-  Reify a                     -> putWord8 35 >> put a
-  ReifyFixity a               -> putWord8 36 >> put a
-  ReifyInstances a b          -> putWord8 37 >> put a >> put b
-  ReifyRoles a                -> putWord8 38 >> put a
-  ReifyAnnotations a b        -> putWord8 39 >> put a >> put b
-  ReifyModule a               -> putWord8 40 >> put a
-  ReifyConStrictness a        -> putWord8 41 >> put a
-  AddDependentFile a          -> putWord8 42 >> put a
-  AddTopDecls a               -> putWord8 43 >> put a
-  IsExtEnabled a              -> putWord8 44 >> put a
-  ExtsEnabled                 -> putWord8 45
-  StartRecover                -> putWord8 46
-  EndRecover a                -> putWord8 47 >> put a
-  QDone                       -> putWord8 48
-  QException a                -> putWord8 49 >> put a
-  QFail a                     -> putWord8 50 >> put a
+  GetBreakpointVar a b        -> putWord8 29 >> put a >> put b
+  StartTH                     -> putWord8 30
+  FinishTH val                -> putWord8 31 >> put val
+  RunTH st q loc ty           -> putWord8 32 >> put st >> put q >> put loc >> put ty
+  NewName a                   -> putWord8 33 >> put a
+  Report a b                  -> putWord8 34 >> put a >> put b
+  LookupName a b              -> putWord8 35 >> put a >> put b
+  Reify a                     -> putWord8 36 >> put a
+  ReifyFixity a               -> putWord8 37 >> put a
+  ReifyInstances a b          -> putWord8 38 >> put a >> put b
+  ReifyRoles a                -> putWord8 39 >> put a
+  ReifyAnnotations a b        -> putWord8 40 >> put a >> put b
+  ReifyModule a               -> putWord8 41 >> put a
+  ReifyConStrictness a        -> putWord8 42 >> put a
+  AddDependentFile a          -> putWord8 43 >> put a
+  AddTopDecls a               -> putWord8 44 >> put a
+  IsExtEnabled a              -> putWord8 45 >> put a
+  ExtsEnabled                 -> putWord8 46
+  StartRecover                -> putWord8 47
+  EndRecover a                -> putWord8 48 >> put a
+  QDone                       -> putWord8 49
+  QException a                -> putWord8 50 >> put a
+  QFail a                     -> putWord8 51  >> put a
 
 -- -----------------------------------------------------------------------------
 -- Reading/writing messages
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
index 865072ea7d..5951d9bf20 100644
--- a/libraries/ghci/GHCi/Run.hs
+++ b/libraries/ghci/GHCi/Run.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP #-}
+{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,
+    UnboxedTuples #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
 -- |
@@ -71,6 +72,9 @@ run m = case m of
     case r of
       Nothing -> return False
       Just w -> return (w /= 0)
+  GetBreakpointVar ref ix -> do
+    aps <- localRef ref
+    mapM mkRemoteRef =<< getIdValFromApStack aps ix
   MallocData bs -> mkString bs
   PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
   FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
@@ -332,3 +336,13 @@ foreign import ccall unsafe "mkCostCentre"
 #else
 mkCostCentre _ _ _ = return nullPtr
 #endif
+
+getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
+getIdValFromApStack apStack (I# stackDepth) = do
+   case getApStackVal# apStack (stackDepth +# 1#) of
+                                -- The +1 is magic!  I don't know where it comes
+                                -- from, but this makes things line up.  --SDM
+        (# ok, result #) ->
+            case ok of
+              0# -> return Nothing -- AP_STACK not found
+              _  -> return (Just (unsafeCoerce# result))