Skip to content

Commit b034cc3

Browse files
SaizanSaizan
committed
[Fix #266] Add InterpreterSettings/DAPDebuggee interface
1 parent 0ee74af commit b034cc3

22 files changed

Lines changed: 571 additions & 457 deletions

‎haskell-debugger.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -104,6 +104,7 @@ library
104104
GHC.Debugger.Runtime.Interpreter.Custom,
105105

106106
GHC.Debugger.Monad,
107+
GHC.Debugger.Debuggee,
107108
GHC.Debugger.Utils,
108109
GHC.Debugger.Utils.Orphans,
109110

@@ -163,6 +164,7 @@ library dap-server
163164
Development.Debug.Adapter.Stopped,
164165
Development.Debug.Adapter.Evaluation,
165166
Development.Debug.Adapter.ExceptionInfo,
167+
Development.Debug.Adapter.DAPDebuggee,
166168
Development.Debug.Adapter.Init,
167169
Development.Debug.Adapter.Interface,
168170
Development.Debug.Adapter.Output,

‎haskell-debugger/GHC/Debugger/Debuggee.hs‎

Lines changed: 267 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,267 @@
1+
{-# LANGUAGE ScopedTypeVariables #-}
2+
{-# LANGUAGE ViewPatterns #-}
3+
{-# LANGUAGE MultilineStrings #-}
4+
{-# LANGUAGE BangPatterns #-}
5+
{-# LANGUAGE CPP #-}
6+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+
{-# LANGUAGE LambdaCase #-}
8+
{-# LANGUAGE NamedFieldPuns #-}
9+
{-# LANGUAGE OverloadedRecordDot #-}
10+
{-# LANGUAGE TupleSections #-}
11+
{-# LANGUAGE TemplateHaskell #-}
12+
{-# LANGUAGE TypeApplications #-}
13+
{-# LANGUAGE RecordWildCards #-}
14+
{-# LANGUAGE NondecreasingIndentation #-}
15+
module GHC.Debugger.Debuggee where
16+
17+
import System.Process
18+
import Control.Concurrent
19+
import Control.Concurrent.Async
20+
import Control.Exception
21+
import Control.Monad
22+
import Control.Monad.IO.Class
23+
import Data.Function
24+
import Data.Functor.Contravariant
25+
import Data.Maybe
26+
import Prelude hiding (mod)
27+
import Data.Text (Text)
28+
import Network.Socket hiding (Debug)
29+
import System.Process.Internals (mkProcessHandle)
30+
import Text.Read (readMaybe)
31+
32+
import GHC
33+
import GHC.Driver.Env as GHC
34+
import GHC.Driver.Monad
35+
import GHC.Driver.Hooks
36+
import GHC.Driver.Ppr
37+
import GHC.Runtime.Interpreter as GHCi
38+
import GHC.Types.Error
39+
import qualified GHC.Utils.Logger as GHC
40+
41+
import GHC.Debugger.Session
42+
import GHC.Debugger.Utils
43+
44+
import Colog.Core as Logger
45+
46+
import GHCi.Message (mkPipeFromHandles)
47+
import System.IO (hGetLine, IOMode(..), openFile, Handle)
48+
import qualified GHC.Linker.Loader as Loader
49+
import GHC.Stack.Annotation
50+
import GHC.Platform.Ways
51+
#if MIN_VERSION_ghc(9,15,0)
52+
import GHC.Data.FastString.Env (emptyFsEnv)
53+
#endif
54+
import GHC.Debugger.Utils.Orphans () -- bring orphan instances to everything which uses `Debugger`
55+
import System.Environment (getExecutablePath)
56+
57+
data InterpreterSettings = InterpreterSettings
58+
{ interpreterFlags :: DynFlags -> DynFlags
59+
, interpreterSetup :: forall a. LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
60+
}
61+
62+
mkInternalInterpreterFlags :: DynFlags -> DynFlags
63+
mkExternalInterpreterFlags :: String -> DynFlags -> DynFlags
64+
(mkInternalInterpreterFlags, mkExternalInterpreterFlags) = (mkInterpreterFlags True "", mkInterpreterFlags False)
65+
where
66+
mkInterpreterFlags :: Bool -> String -> DynFlags -> DynFlags
67+
mkInterpreterFlags preferInternalInterpreter externalInterpreterProg df = df
68+
-- Enable the external interpreter by default! See #169
69+
-- See Note [Custom external interpreter]
70+
& enableExternalInterpreter preferInternalInterpreter
71+
-- Ext interp is the same program as this, with "--external-interpreter"
72+
-- (this is ignored on GHC 9.14, see Note [Custom external interpreter])
73+
& setPgmI externalInterpreterProg
74+
-- ideally, we'd set "external-interpreter" *before* the file
75+
-- descriptors. since there's no way to do that yet, we just have
76+
-- some logic in main to detect [writefd, readfd, --external-interpreter]
77+
& addOptI "--external-interpreter"
78+
79+
80+
mkInternalInterpreterSetup :: LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
81+
mkInternalInterpreterSetup _ dflags mainGhcThread = do
82+
when (gopt Opt_ExternalInterpreter dflags) $ do
83+
throw $ InconsistentInterpreterFlags $ "Used ghc flag -fexternal-interpreter together with --internal-interpreter haskell-debugger flag."
84+
mainGhcThread
85+
86+
newtype InconsistentInterpreterFlags = InconsistentInterpreterFlags String
87+
instance Show InconsistentInterpreterFlags where
88+
show (InconsistentInterpreterFlags t) = "Interpreter flags are inconsistent: " ++ t
89+
instance Exception InconsistentInterpreterFlags
90+
91+
92+
mkExternalInterpreterFromIOSetup :: IO Interp -> LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
93+
mkExternalInterpreterFromIOSetup m _l dflags mainGhcThread = do
94+
unless (gopt Opt_ExternalInterpreter dflags) $ do
95+
throw $ InconsistentInterpreterFlags $ "Used ghc flag -fno-external-interpreter instead of --internal-interpreter haskell-debugger flag."
96+
-- we supply our custom external interpreter process, which is
97+
-- already running and connected to the user's terminal.
98+
extInterp <- liftIO
99+
$ annotateStackStringIO "Waiting for an external interpreter run-in-terminal process"
100+
$ m
101+
modifySession $ \h -> h
102+
{ hsc_interp = Just extInterp -- set it directly!
103+
}
104+
105+
-- Ext interp is running in user terminal, no need to forward output to logger
106+
mainGhcThread
107+
108+
109+
mkExternalInterpreterFromStdInSetup :: StdStream -> LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
110+
mkExternalInterpreterFromStdInSetup givenStdStream l dflags mainGhcThread = do
111+
unless (gopt Opt_ExternalInterpreter dflags) $ do
112+
throw $ InconsistentInterpreterFlags $ "Used ghc flag -fno-external-interpreter instead of --internal-interpreter haskell-debugger flag."
113+
114+
(putHandles,fwdThread) <- liftIO $ externalInterpFwdThread l
115+
-- Make sure to override the function which creates the external
116+
-- interpreter, because we need to keep track of the standard handles
117+
modifySession $ \h -> h
118+
{ hsc_hooks = (hsc_hooks h)
119+
{ createIservProcessHook = Just $ \cp -> do
120+
-- See Note [External interpreter buffering]
121+
(_, Just o, Just e, ph) <-
122+
createProcess cp
123+
{ std_in = givenStdStream
124+
, std_out = CreatePipe
125+
, std_err = CreatePipe
126+
-- Override executable path
127+
-- See Note [Custom external interpreter]
128+
#if MIN_VERSION_ghc(9,15,0)
129+
#else
130+
, cmdspec = case cmdspec cp of
131+
ShellCommand (words -> ws) -> ShellCommand $ unwords $ getPgmI dflags : drop 1 ws
132+
RawCommand _fp args -> RawCommand (getPgmI dflags) args
133+
#endif
134+
}
135+
putHandles (o, e)
136+
return ph
137+
}
138+
}
139+
let
140+
-- We launched the external interpreter as a child process, so forward its output to the logger.
141+
withUnliftGhc $ \ unlift -> annotateCallStackIO $ do
142+
withAsync (annotateCallStackIO $ void $ fwdThread) $ \ fwd_thr -> do
143+
liftIO $ annotateCallStackIO $ link fwd_thr
144+
annotateCallStackIO $ unlift mainGhcThread
145+
146+
externalInterpFwdThread :: LogAction IO DebuggerLog ->
147+
IO ((Handle, Handle) -> IO (), IO ())
148+
externalInterpFwdThread l = do
149+
iserv_handles <- liftIO newEmptyMVar
150+
-- The external interpreter is spawned lazily, so we block waiting for
151+
-- the handles to be available in a new thread.
152+
let
153+
fwdThread = takeMVar iserv_handles >>= \ (serv_out, serv_err) ->
154+
concurrently_
155+
(forwardHandleToLogger serv_err (contramap LogDebuggeeErr l))
156+
(forwardHandleToLogger serv_out (contramap LogDebuggeeOut l))
157+
return (putMVar iserv_handles, fwdThread)
158+
159+
-- | Make an 'ExtInterpInstance' based on an external interpreter process that
160+
-- was launched by the DAP client via 'runInTerminal'. The process sends its
161+
-- own PID as the first line on the socket before the GHCi wire protocol
162+
-- begins.
163+
extInterpFromTerminalProcess :: Socket -> IO Interp
164+
extInterpFromTerminalProcess sock0 = do
165+
port <- socketPort sock0
166+
putStrLn $ "Connected to " ++ show port
167+
Control.Exception.bracketOnError
168+
(accept sock0)
169+
(\ (sock,_) -> close sock0 >> close sock)
170+
(\ (sock,_) -> do
171+
bi_h <- socketToHandle sock ReadWriteMode
172+
173+
pidLine <- annotateCallStackIO $ hGetLine bi_h
174+
175+
pid <- case readMaybe pidLine :: Maybe Int of
176+
Just pid -> pure pid
177+
Nothing -> fail $ "invalid external interpreter PID on socket: " ++ show pidLine
178+
ph <- mkProcessHandle (fromIntegral pid) False
179+
interpPipe <- mkPipeFromHandles bi_h bi_h
180+
lock <- newMVar ()
181+
let process = InterpProcess
182+
{ interpHandle = ph
183+
, interpPipe
184+
, interpLock = lock
185+
}
186+
187+
pending_frees <- newMVar []
188+
let inst = ExtInterpInstance
189+
{ instProcess = process
190+
, instPendingFrees = pending_frees
191+
, instExtra = ()
192+
}
193+
conf = IServConfig
194+
{ iservConfProgram = "the process is already running, we should never need to run it again"
195+
, iservConfOpts = []
196+
-- VERY IMPORTANT: See Note [Dynamic dependencies for dynamic debugger]
197+
, iservConfDynamic = hostIsDynamic
198+
, iservConfProfiled = hostIsProfiled
199+
, iservConfHook = Nothing -- it's already running!
200+
, iservConfTrace = pure ()
201+
}
202+
203+
lookup_cache <- mkInterpSymbolCache
204+
s <- newMVar $ InterpRunning inst
205+
loader <- Loader.uninitializedLoader
206+
#if MIN_VERSION_ghc(9,15,0)
207+
fs_cache <- newMVar emptyFsEnv
208+
return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache fs_cache)
209+
#else
210+
return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)
211+
#endif
212+
)
213+
214+
mkCliInterpreterSettings :: Bool -> Maybe FilePath -> IO InterpreterSettings
215+
mkCliInterpreterSettings internalInterpreter debuggeeStdin = do
216+
if internalInterpreter then pure $ InterpreterSettings { interpreterFlags = mkInternalInterpreterFlags
217+
, interpreterSetup = mkInternalInterpreterSetup } else do
218+
stdinStream <- case debuggeeStdin of
219+
Just fp -> UseHandle <$> System.IO.openFile fp ReadMode
220+
Nothing -> pure Inherit
221+
-- the same program invoked with `external-interpreter` serves as the external interpreter
222+
thisProg <- getExecutablePath
223+
pure InterpreterSettings { interpreterFlags = mkExternalInterpreterFlags thisProg
224+
, interpreterSetup = mkExternalInterpreterFromStdInSetup stdinStream
225+
}
226+
227+
--------------------------------------------------------------------------------
228+
-- * Logging
229+
--------------------------------------------------------------------------------
230+
231+
-- | A debugger log. May include debuggee ouput.
232+
data DebuggerLog
233+
= DebuggerLog !Logger.Severity !DebuggerMessage
234+
| GHCLog !GHC.LogFlags !MessageClass !SrcSpan !SDoc
235+
| LogDebuggeeOut !Text
236+
| LogDebuggeeErr !Text
237+
238+
-- | A debugger log message
239+
data DebuggerMessage
240+
= LogSDoc !DynFlags !SDoc
241+
| LogFailedToCompileDebugViewModule !GHC.ModuleName
242+
| LogSkippingViewModuleNoPkg !GHC.ModuleName String [String]
243+
244+
instance Show DebuggerMessage where
245+
show = \ case
246+
LogFailedToCompileDebugViewModule mn ->
247+
"Failed to compile built-in " ++ moduleNameString mn ++ " module! Ignoring these custom debug views."
248+
LogSkippingViewModuleNoPkg mn pkg uids ->
249+
"Skipping compilation of built-in " ++ moduleNameString mn ++ " module because package "
250+
++ show pkg ++ " wasn't found in dependencies " ++ show uids
251+
LogSDoc dflags doc -> showSDoc dflags doc
252+
253+
254+
ghcLogAction :: LogAction IO DebuggerLog -> GHC.LogAction
255+
ghcLogAction l = \logflags mclass srcSpan sdoc -> do
256+
liftLogIO l <& GHCLog logflags mclass srcSpan sdoc
257+
258+
msgClassSeverity :: MessageClass -> Logger.Severity
259+
msgClassSeverity = \case
260+
MCOutput -> Info
261+
MCFatal -> Logger.Error
262+
MCInteractive -> Info
263+
MCDump -> Debug
264+
MCInfo -> Info
265+
MCDiagnostic SevIgnore _ _ -> Debug -- ?
266+
MCDiagnostic SevWarning _ _ -> Logger.Warning
267+
MCDiagnostic SevError _ _ -> Logger.Error

0 commit comments

Comments
 (0)