A little closer to supporting breakpoints with -fexternal-interpreter
authorSimon Marlow <marlowsd@gmail.com>
Wed, 13 Jan 2016 09:13:14 +0000 (09:13 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Wed, 13 Jan 2016 13:06:07 +0000 (13:06 +0000)
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

compiler/ghci/GHCi.hs
compiler/main/InteractiveEval.hs
libraries/ghci/GHCi/Message.hs
libraries/ghci/GHCi/Run.hs

index 2b4abdd..a610931 100644 (file)
@@ -18,6 +18,7 @@ module GHCi
   , newBreakArray
   , enableBreakpoint
   , breakpointStatus
+  , getBreakpointVar
 
   -- * The object-code linker
   , initObjLinker
@@ -276,6 +277,11 @@ breakpointStatus hsc_env ref ix = do
   withForeignRef ref $ \breakarray ->
     iservCmd hsc_env (BreakpointStatus breakarray ix)
 
+getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)
+getBreakpointVar hsc_env ref ix =
+  withForeignRef ref $ \apStack -> do
+    mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)
+    mapM (mkFinalizedHValue hsc_env) mb
 
 -- -----------------------------------------------------------------------------
 -- Interface to the object-code linker
@@ -454,36 +460,36 @@ HValue is a direct reference to an value in the local heap.  Obviously
 we cannot use this to refer to things in the external process.
 
 
-HValueRef
+RemoteRef
 ---------
 
-HValueRef is a StablePtr to a heap-resident value.  When
+RemoteRef is a StablePtr to a heap-resident value.  When
 -fexternal-interpreter is used, this value resides in the external
-process's heap.  HValueRefs are mostly used to send pointers in
+process's heap.  RemoteRefs are mostly used to send pointers in
 messages between GHC and iserv.
 
-An HValueRef must be explicitly freed when no longer required, using
+A RemoteRef must be explicitly freed when no longer required, using
 freeHValueRefs, or by attaching a finalizer with mkForeignHValue.
 
-To get from an HValueRef to an HValue you can use 'wormholeRef', which
+To get from a RemoteRef to an HValue you can use 'wormholeRef', which
 fails with an error message if -fexternal-interpreter is in use.
 
-ForeignHValue
--------------
+ForeignRef
+----------
 
-A ForeignHValue is an HValueRef with a finalizer that will free the
-'HValueRef' when it is gargabe collected.  We mostly use ForeignHValue
+A ForeignRef is a RemoteRef with a finalizer that will free the
+'RemoteRef' when it is gargabe collected.  We mostly use ForeignHValue
 on the GHC side.
 
-The finalizer adds the HValueRef to the iservPendingFrees list in the
-IServ record.  The next call to iservCmd will free any HValueRefs in
+The finalizer adds the RemoteRef to the iservPendingFrees list in the
+IServ record.  The next call to iservCmd will free any RemoteRefs in
 the list.  It was done this way rather than calling iservCmd directly,
 because I didn't want to have arbitrary threads calling iservCmd.  In
 principle it would probably be ok, but it seems less hairy this way.
 -}
 
--- | Creates a 'ForeignHValue' that will automatically release the
--- 'HValueRef' when it is no longer referenced.
+-- | Creates a 'ForeignRef' that will automatically release the
+-- 'RemoteRef' when it is no longer referenced.
 mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a)
 mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free
  where
@@ -504,15 +510,15 @@ freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()
 freeHValueRefs _ [] = return ()
 freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs)
 
--- | Convert a 'ForeignHValue' to an 'HValue' directly.  This only works
--- when the interpreter is running in the same process as the compiler,
--- so it fails when @-fexternal-interpreter@ is on.
+-- | Convert a 'ForeignRef' to the value it references directly.  This
+-- only works when the interpreter is running in the same process as
+-- the compiler, so it fails when @-fexternal-interpreter@ is on.
 wormhole :: DynFlags -> ForeignRef a -> IO a
 wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r)
 
--- | Convert an 'HValueRef' to an 'HValue' directly.  This only works
--- when the interpreter is running in the same process as the compiler,
--- so it fails when @-fexternal-interpreter@ is on.
+-- | Convert an 'RemoteRef' to the value it references directly.  This
+-- only works when the interpreter is running in the same process as
+-- the compiler, so it fails when @-fexternal-interpreter@ is on.
 wormholeRef :: DynFlags -> RemoteRef a -> IO a
 wormholeRef dflags r
   | gopt Opt_ExternalInterpreter dflags
index 013be3c..47d282e 100644 (file)
@@ -521,8 +521,8 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
    -- has been accidentally evaluated, or something else has gone wrong.
    -- So that we don't fall over in a heap when this happens, just don't
    -- bind any free variables instead, and we emit a warning.
-   apStack <- wormhole (hsc_dflags hsc_env) apStack_fhv
-   mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets)
+   mb_hValues <-
+      mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets
    when (any isNothing mb_hValues) $
       debugTraceMsg (hsc_dflags hsc_env) 1 $
           text "Warning: _result has been evaluated, some bindings have been lost"
@@ -545,8 +545,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
        ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
        names  = map idName new_ids
 
-   fhvs <- mapM (mkFinalizedHValue hsc_env <=< mkRemoteRef)
-             (catMaybes mb_hValues)
+   let fhvs = catMaybes mb_hValues
    Linker.extendLinkEnv (zip names fhvs)
    when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]
    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
@@ -604,16 +603,6 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
                  let ic' = substInteractiveContext ic subst
                  return hsc_env{hsc_IC=ic'}
 
-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))
-
 pushResume :: HscEnv -> Resume -> HscEnv
 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
   where
index 45b1951..a22767a 100644 (file)
@@ -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
index 865072e..5951d9b 100644 (file)
@@ -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))