Commit 3e796e1a authored by Simon Marlow's avatar Simon Marlow
Browse files

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
parent 6cb860a9
...@@ -18,6 +18,7 @@ module GHCi ...@@ -18,6 +18,7 @@ module GHCi
, newBreakArray , newBreakArray
, enableBreakpoint , enableBreakpoint
, breakpointStatus , breakpointStatus
, getBreakpointVar
-- * The object-code linker -- * The object-code linker
, initObjLinker , initObjLinker
...@@ -276,6 +277,11 @@ breakpointStatus hsc_env ref ix = do ...@@ -276,6 +277,11 @@ breakpointStatus hsc_env ref ix = do
withForeignRef ref $ \breakarray -> withForeignRef ref $ \breakarray ->
iservCmd hsc_env (BreakpointStatus breakarray ix) 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 -- Interface to the object-code linker
...@@ -454,36 +460,36 @@ HValue is a direct reference to an value in the local heap. Obviously ...@@ -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. 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 -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. 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. 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. 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 A ForeignRef is a RemoteRef with a finalizer that will free the
'HValueRef' when it is gargabe collected. We mostly use ForeignHValue 'RemoteRef' when it is gargabe collected. We mostly use ForeignHValue
on the GHC side. on the GHC side.
The finalizer adds the HValueRef to the iservPendingFrees list in the The finalizer adds the RemoteRef to the iservPendingFrees list in the
IServ record. The next call to iservCmd will free any HValueRefs in IServ record. The next call to iservCmd will free any RemoteRefs in
the list. It was done this way rather than calling iservCmd directly, the list. It was done this way rather than calling iservCmd directly,
because I didn't want to have arbitrary threads calling iservCmd. In 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. principle it would probably be ok, but it seems less hairy this way.
-} -}
-- | Creates a 'ForeignHValue' that will automatically release the -- | Creates a 'ForeignRef' that will automatically release the
-- 'HValueRef' when it is no longer referenced. -- 'RemoteRef' when it is no longer referenced.
mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a) mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free
where where
...@@ -504,15 +510,15 @@ freeHValueRefs :: HscEnv -> [HValueRef] -> IO () ...@@ -504,15 +510,15 @@ freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()
freeHValueRefs _ [] = return () freeHValueRefs _ [] = return ()
freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs) freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs)
-- | Convert a 'ForeignHValue' to an 'HValue' directly. This only works -- | Convert a 'ForeignRef' to the value it references directly. This
-- when the interpreter is running in the same process as the compiler, -- only works when the interpreter is running in the same process as
-- so it fails when @-fexternal-interpreter@ is on. -- the compiler, so it fails when @-fexternal-interpreter@ is on.
wormhole :: DynFlags -> ForeignRef a -> IO a wormhole :: DynFlags -> ForeignRef a -> IO a
wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r) wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r)
-- | Convert an 'HValueRef' to an 'HValue' directly. This only works -- | Convert an 'RemoteRef' to the value it references directly. This
-- when the interpreter is running in the same process as the compiler, -- only works when the interpreter is running in the same process as
-- so it fails when @-fexternal-interpreter@ is on. -- the compiler, so it fails when @-fexternal-interpreter@ is on.
wormholeRef :: DynFlags -> RemoteRef a -> IO a wormholeRef :: DynFlags -> RemoteRef a -> IO a
wormholeRef dflags r wormholeRef dflags r
| gopt Opt_ExternalInterpreter dflags | gopt Opt_ExternalInterpreter dflags
......
...@@ -521,8 +521,8 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do ...@@ -521,8 +521,8 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
-- has been accidentally evaluated, or something else has gone wrong. -- 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 -- 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. -- bind any free variables instead, and we emit a warning.
apStack <- wormhole (hsc_dflags hsc_env) apStack_fhv mb_hValues <-
mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets) mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets
when (any isNothing mb_hValues) $ when (any isNothing mb_hValues) $
debugTraceMsg (hsc_dflags hsc_env) 1 $ debugTraceMsg (hsc_dflags hsc_env) 1 $
text "Warning: _result has been evaluated, some bindings have been lost" text "Warning: _result has been evaluated, some bindings have been lost"
...@@ -545,8 +545,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do ...@@ -545,8 +545,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
names = map idName new_ids names = map idName new_ids
fhvs <- mapM (mkFinalizedHValue hsc_env <=< mkRemoteRef) let fhvs = catMaybes mb_hValues
(catMaybes mb_hValues)
Linker.extendLinkEnv (zip names fhvs) Linker.extendLinkEnv (zip names fhvs)
when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)] when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]
hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
...@@ -604,16 +603,6 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do ...@@ -604,16 +603,6 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
let ic' = substInteractiveContext ic subst let ic' = substInteractiveContext ic subst
return hsc_env{hsc_IC=ic'} 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 :: HscEnv -> Resume -> HscEnv
pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 } pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
where where
......
...@@ -152,6 +152,12 @@ data Message a where ...@@ -152,6 +152,12 @@ data Message a where
-> Int -- index -> Int -- index
-> Message Bool -- True <=> enabled -> 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 ------------------------------------------- -- Template Haskell -------------------------------------------
-- | Start a new TH module, return a state token that should be -- | Start a new TH module, return a state token that should be
...@@ -333,27 +339,28 @@ getMessage = do ...@@ -333,27 +339,28 @@ getMessage = do
26 -> Msg <$> (NewBreakArray <$> get) 26 -> Msg <$> (NewBreakArray <$> get)
27 -> Msg <$> (EnableBreakpoint <$> get <*> get <*> get) 27 -> Msg <$> (EnableBreakpoint <$> get <*> get <*> get)
28 -> Msg <$> (BreakpointStatus <$> get <*> get) 28 -> Msg <$> (BreakpointStatus <$> get <*> get)
29 -> Msg <$> return StartTH 29 -> Msg <$> (GetBreakpointVar <$> get <*> get)
30 -> Msg <$> FinishTH <$> get 30 -> Msg <$> return StartTH
31 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get) 31 -> Msg <$> FinishTH <$> get
32 -> Msg <$> NewName <$> get 32 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
33 -> Msg <$> (Report <$> get <*> get) 33 -> Msg <$> NewName <$> get
34 -> Msg <$> (LookupName <$> get <*> get) 34 -> Msg <$> (Report <$> get <*> get)
35 -> Msg <$> Reify <$> get 35 -> Msg <$> (LookupName <$> get <*> get)
36 -> Msg <$> ReifyFixity <$> get 36 -> Msg <$> Reify <$> get
37 -> Msg <$> (ReifyInstances <$> get <*> get) 37 -> Msg <$> ReifyFixity <$> get
38 -> Msg <$> ReifyRoles <$> get 38 -> Msg <$> (ReifyInstances <$> get <*> get)
39 -> Msg <$> (ReifyAnnotations <$> get <*> get) 39 -> Msg <$> ReifyRoles <$> get
40 -> Msg <$> ReifyModule <$> get 40 -> Msg <$> (ReifyAnnotations <$> get <*> get)
41 -> Msg <$> ReifyConStrictness <$> get 41 -> Msg <$> ReifyModule <$> get
42 -> Msg <$> AddDependentFile <$> get 42 -> Msg <$> ReifyConStrictness <$> get
43 -> Msg <$> AddTopDecls <$> get 43 -> Msg <$> AddDependentFile <$> get
44 -> Msg <$> (IsExtEnabled <$> get) 44 -> Msg <$> AddTopDecls <$> get
45 -> Msg <$> return ExtsEnabled 45 -> Msg <$> (IsExtEnabled <$> get)
46 -> Msg <$> return StartRecover 46 -> Msg <$> return ExtsEnabled
47 -> Msg <$> EndRecover <$> get 47 -> Msg <$> return StartRecover
48 -> Msg <$> return QDone 48 -> Msg <$> EndRecover <$> get
49 -> Msg <$> QException <$> get 49 -> Msg <$> return QDone
50 -> Msg <$> QException <$> get
_ -> Msg <$> QFail <$> get _ -> Msg <$> QFail <$> get
putMessage :: Message a -> Put putMessage :: Message a -> Put
...@@ -387,28 +394,29 @@ putMessage m = case m of ...@@ -387,28 +394,29 @@ putMessage m = case m of
NewBreakArray sz -> putWord8 26 >> put sz NewBreakArray sz -> putWord8 26 >> put sz
EnableBreakpoint arr ix b -> putWord8 27 >> put arr >> put ix >> put b EnableBreakpoint arr ix b -> putWord8 27 >> put arr >> put ix >> put b
BreakpointStatus arr ix -> putWord8 28 >> put arr >> put ix BreakpointStatus arr ix -> putWord8 28 >> put arr >> put ix
StartTH -> putWord8 29 GetBreakpointVar a b -> putWord8 29 >> put a >> put b
FinishTH val -> putWord8 30 >> put val StartTH -> putWord8 30
RunTH st q loc ty -> putWord8 31 >> put st >> put q >> put loc >> put ty FinishTH val -> putWord8 31 >> put val
NewName a -> putWord8 32 >> put a RunTH st q loc ty -> putWord8 32 >> put st >> put q >> put loc >> put ty
Report a b -> putWord8 33 >> put a >> put b NewName a -> putWord8 33 >> put a
LookupName a b -> putWord8 34 >> put a >> put b Report a b -> putWord8 34 >> put a >> put b
Reify a -> putWord8 35 >> put a LookupName a b -> putWord8 35 >> put a >> put b
ReifyFixity a -> putWord8 36 >> put a Reify a -> putWord8 36 >> put a
ReifyInstances a b -> putWord8 37 >> put a >> put b ReifyFixity a -> putWord8 37 >> put a
ReifyRoles a -> putWord8 38 >> put a ReifyInstances a b -> putWord8 38 >> put a >> put b
ReifyAnnotations a b -> putWord8 39 >> put a >> put b ReifyRoles a -> putWord8 39 >> put a
ReifyModule a -> putWord8 40 >> put a ReifyAnnotations a b -> putWord8 40 >> put a >> put b
ReifyConStrictness a -> putWord8 41 >> put a ReifyModule a -> putWord8 41 >> put a
AddDependentFile a -> putWord8 42 >> put a ReifyConStrictness a -> putWord8 42 >> put a
AddTopDecls a -> putWord8 43 >> put a AddDependentFile a -> putWord8 43 >> put a
IsExtEnabled a -> putWord8 44 >> put a AddTopDecls a -> putWord8 44 >> put a
ExtsEnabled -> putWord8 45 IsExtEnabled a -> putWord8 45 >> put a
StartRecover -> putWord8 46 ExtsEnabled -> putWord8 46
EndRecover a -> putWord8 47 >> put a StartRecover -> putWord8 47
QDone -> putWord8 48 EndRecover a -> putWord8 48 >> put a
QException a -> putWord8 49 >> put a QDone -> putWord8 49
QFail a -> putWord8 50 >> put a QException a -> putWord8 50 >> put a
QFail a -> putWord8 51 >> put a
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Reading/writing messages -- Reading/writing messages
......
{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP #-} {-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,
UnboxedTuples #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-- | -- |
...@@ -71,6 +72,9 @@ run m = case m of ...@@ -71,6 +72,9 @@ run m = case m of
case r of case r of
Nothing -> return False Nothing -> return False
Just w -> return (w /= 0) Just w -> return (w /= 0)
GetBreakpointVar ref ix -> do
aps <- localRef ref
mapM mkRemoteRef =<< getIdValFromApStack aps ix
MallocData bs -> mkString bs MallocData bs -> mkString bs
PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
FreeFFI p -> freeForeignCallInfo (fromRemotePtr p) FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
...@@ -332,3 +336,13 @@ foreign import ccall unsafe "mkCostCentre" ...@@ -332,3 +336,13 @@ foreign import ccall unsafe "mkCostCentre"
#else #else
mkCostCentre _ _ _ = return nullPtr mkCostCentre _ _ _ = return nullPtr
#endif #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))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment