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
, 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
......
......@@ -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
......
......@@ -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
......
{-# 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))
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