#include "HsVersions.h"
-#if defined(GHCI) && defined(BREAKPOINT)
-import GHC.Exts ( Int(..), Ptr(..), int2Addr# )
-import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr )
-import System.IO.Unsafe ( unsafePerformIO )
-import Var
-import HscTypes
-import RdrName
-import NameEnv
-import TcType
-import qualified Id
-import IdInfo
-import PrelNames
-#endif
+import GhciMonad
-- The GHC interface
import qualified GHC
-- Other random utilities
import Digraph
-import BasicTypes
-import Panic hiding (showException)
+import BasicTypes hiding (isTopLevel)
+import Panic hiding (showException)
import Config
import StaticFlags
import Linker
import Util
+-- The debugger
+import Debugger
+import HscTypes
+import Id
+import Var ( globaliseId )
+import IdInfo
+import NameEnv
+import RdrName
+import Module
+import Type
+import TcType
+
#ifndef mingw32_HOST_OS
import System.Posix
#if __GLASGOW_HASKELL__ > 504
--import SystemExts
import Control.Exception as Exception
-import Data.Dynamic
-- import Control.Concurrent
-import Numeric
import Data.List
-import Data.Int ( Int64 )
import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes )
import System.Cmd
-import System.CPUTime
import System.Environment
import System.Exit ( exitWith, ExitCode(..) )
import System.Directory
import System.IO
import System.IO.Error as IO
import Data.Char
+import Data.Dynamic
+import Data.Array
import Control.Monad as Monad
-import Foreign.StablePtr ( newStablePtr )
+import Foreign.StablePtr ( StablePtr, newStablePtr, deRefStablePtr, freeStablePtr )
import GHC.Exts ( unsafeCoerce# )
-import GHC.IOBase ( IOErrorType(InvalidArgument) )
+import GHC.IOBase ( IOErrorType(InvalidArgument), IO(IO) )
-import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
+import Data.IORef ( IORef, readIORef, writeIORef )
import System.Posix.Internals ( setNonBlockingFD )
+-- these are needed by the new ghci debugger
+import ByteCodeLink (HValue)
+import ByteCodeInstr (BreakInfo (..))
+import BreakArray
+import TickTree
+
-----------------------------------------------------------------------------
ghciWelcomeMsg =
builtin_commands :: [Command]
builtin_commands = [
- ("add", keepGoingPaths addModule, False, completeFilename),
+ -- Hugs users are accustomed to :e, so make sure it doesn't overlap
+ ("?", keepGoing help, False, completeNone),
+ ("add", tlC$ keepGoingPaths addModule, False, completeFilename),
+ ("break", breakCmd, False, completeNone),
("browse", keepGoing browseCmd, False, completeModule),
- ("cd", keepGoing changeDirectory, False, completeFilename),
+ ("cd", tlC$ keepGoing changeDirectory, False, completeFilename),
+ ("check", keepGoing checkModule, False, completeHomeModule),
+ ("continue", continueCmd, False, completeNone),
+ ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
("def", keepGoing defineMacro, False, completeIdentifier),
+ ("delete", deleteCmd, False, completeNone),
("e", keepGoing editFile, False, completeFilename),
- -- Hugs users are accustomed to :e, so make sure it doesn't overlap
("edit", keepGoing editFile, False, completeFilename),
+ ("etags", keepGoing createETagsFileCmd, False, completeFilename),
+ ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier),
("help", keepGoing help, False, completeNone),
- ("?", keepGoing help, False, completeNone),
("info", keepGoing info, False, completeIdentifier),
- ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
+ ("kind", keepGoing kindOfType, False, completeIdentifier),
+ ("load", tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
("module", keepGoing setContext, False, completeModule),
- ("main", keepGoing runMain, False, completeIdentifier),
- ("reload", keepGoing reloadModule, False, completeNone),
- ("check", keepGoing checkModule, False, completeHomeModule),
+ ("main", tlC$ keepGoing runMain, False, completeIdentifier),
+ ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
+ ("quit", quit, False, completeNone),
+ ("reload", tlC$ keepGoing reloadModule, False, completeNone),
("set", keepGoing setCmd, True, completeSetOptions),
("show", keepGoing showCmd, False, completeNone),
- ("etags", keepGoing createETagsFileCmd, False, completeFilename),
- ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
+ ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier),
+ ("step", stepCmd, False, completeNone),
("type", keepGoing typeOfExpr, False, completeIdentifier),
- ("kind", keepGoing kindOfType, False, completeIdentifier),
- ("unset", keepGoing unsetOptions, True, completeSetOptions),
("undef", keepGoing undefineMacro, False, completeMacro),
- ("quit", quit, False, completeNone)
+ ("unset", keepGoing unsetOptions, True, completeSetOptions)
]
keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
keepGoing a str = a str >> return False
+-- tlC: Top Level Command, not allowed in inferior sessions
+tlC :: (String -> GHCi Bool) -> (String -> GHCi Bool)
+tlC a str = do
+ top_level <- isTopLevel
+ if not top_level
+ then throwDyn (CmdLineError "Command only allowed at Top Level")
+ else a str
+
keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
keepGoingPaths a str = a (toArgs str) >> return False
" :edit edit last module\n" ++
" :help, :? display this list of commands\n" ++
" :info [<name> ...] display information about the given names\n" ++
+ " :print [<name> ...] prints a value without forcing its computation\n" ++
+ " :sprint [<name> ...] simplified version of :print\n" ++
" :load <filename> ... load module(s) and their dependents\n" ++
" :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
" :main [<arguments> ...] run the main function with the given arguments\n" ++
" +s print timing/memory stats after each evaluation\n" ++
" +t print type after evaluation\n" ++
" -<flags> most GHC command line flags can also be set here\n" ++
- " (eg. -v2, -fglasgow-exts, etc.)\n"
-
-
-#if defined(GHCI) && defined(BREAKPOINT)
-globaliseAndTidy :: Id -> Id
-globaliseAndTidy id
--- Give the Id a Global Name, and tidy its type
- = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
- where
- tidy_type = tidyTopType (idType id)
-
-
-printScopeMsg :: Session -> String -> [Id] -> IO ()
-printScopeMsg session location ids
- = GHC.getPrintUnqual session >>= \unqual ->
- printForUser stdout unqual $
- text "Local bindings in scope:" $$
- nest 2 (pprWithCommas showId ids)
- where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
-
-jumpCondFunction :: Session -> Int -> [HValue] -> String -> Bool -> b -> b
-jumpCondFunction session ptr hValues location True b = b
-jumpCondFunction session ptr hValues location False b
- = jumpFunction session ptr hValues location b
-
-jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
-jumpFunction session@(Session ref) (I# idsPtr) hValues location b
- = unsafePerformIO $
- do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
- let names = map idName ids
- ASSERT (length names == length hValues) return ()
- printScopeMsg session location ids
- hsc_env <- readIORef ref
-
- let ictxt = hsc_IC hsc_env
- global_ids = map globaliseAndTidy ids
- rn_env = ic_rn_local_env ictxt
- type_env = ic_type_env ictxt
- bound_names = map idName global_ids
- new_rn_env = extendLocalRdrEnv rn_env bound_names
- -- Remove any shadowed bindings from the type_env;
- -- they are inaccessible but might, I suppose, cause
- -- a space leak if we leave them there
- shadowed = [ n | name <- bound_names,
- let rdr_name = mkRdrUnqual (nameOccName name),
- Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
- filtered_type_env = delListFromNameEnv type_env shadowed
- new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
- new_ic = ictxt { ic_rn_local_env = new_rn_env,
- ic_type_env = new_type_env }
- writeIORef ref (hsc_env { hsc_IC = new_ic })
- is_tty <- hIsTerminalDevice stdin
- prel_mod <- GHC.findModule session prel_name Nothing
- default_editor <- findEditor
- withExtendedLinkEnv (zip names hValues) $
- startGHCi (interactiveLoop is_tty True)
- GHCiState{ progname = "<interactive>",
- args = [],
- prompt = location++"> ",
- editor = default_editor,
- session = session,
- options = [],
- prelude = prel_mod }
- writeIORef ref hsc_env
- putStrLn $ "Returning to normal execution..."
- return b
-#endif
+ " (eg. -v2, -fglasgow-exts, etc.)\n" ++
+ "\n"
+-- Todo: add help for breakpoint commands here
findEditor = do
getEnv "EDITOR"
interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
interactiveUI session srcs maybe_expr = do
-#if defined(GHCI) && defined(BREAKPOINT)
- initDynLinker =<< GHC.getSessionDynFlags session
- extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
- ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]
-#endif
-- HACK! If we happen to get into an infinite loop (eg the user
-- types 'let x=x in x' at the prompt), then the thread will block
-- on a blackhole, and become unreachable during GC. The GC will
hSetBuffering stdin NoBuffering
-- initial context is just the Prelude
- prel_mod <- GHC.findModule session prel_name Nothing
+ prel_mod <- GHC.findModule session prel_name (Just basePackageId)
GHC.setContext session [] [prel_mod]
#ifdef USE_READLINE
editor = default_editor,
session = session,
options = [],
- prelude = prel_mod }
+ prelude = prel_mod,
+ topLevel = True,
+ resume = [],
+ breaks = emptyActiveBreakPoints
+ }
#ifdef USE_READLINE
Readline.resetTerminal Nothing
-- failure to run the command causes exit(1) for ghc -e.
_ -> finishEvalExpr nms
--- This is the exception handler for exceptions generated by the
--- user's code; it normally just prints out the exception. The
--- handler must be recursive, in case showing the exception causes
--- more exceptions to be raised.
---
--- Bugfix: if the user closed stdout or stderr, the flushing will fail,
--- raising another exception. We therefore don't put the recursive
--- handler arond the flushing operation, so if stderr is closed
--- GHCi will just die gracefully rather than going into an infinite loop.
-handler :: Exception -> GHCi Bool
-handler exception = do
- flushInterpBuffers
- io installSignalHandlers
- ghciHandle handler (showException exception >> return False)
-
-showException (DynException dyn) =
- case fromDynamic dyn of
- Nothing -> io (putStrLn ("*** Exception: (unknown)"))
- Just Interrupted -> io (putStrLn "Interrupted.")
- Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
- Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
- Just other_ghc_ex -> io (print other_ghc_ex)
-
-showException other_exception
- = io (putStrLn ("*** Exception: " ++ show other_exception))
-
runStmt :: String -> GHCi (Maybe [Name])
runStmt stmt
| null (filter (not.isSpace) stmt) = return (Just [])
session <- getSession
result <- io $ withProgName (progname st) $ withArgs (args st) $
GHC.runStmt session stmt
- case result of
- GHC.RunFailed -> return Nothing
- GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
- GHC.RunOk names -> return (Just names)
+ switchOnRunResult result
+
+switchOnRunResult :: GHC.RunResult -> GHCi (Maybe [Name])
+switchOnRunResult GHC.RunFailed = return Nothing
+switchOnRunResult (GHC.RunException e) = throw e
+switchOnRunResult (GHC.RunOk names) = return $ Just names
+switchOnRunResult (GHC.RunBreak apStack _threadId info resume) = do -- Todo: we don't use threadID, perhaps delete?
+ session <- getSession
+ Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info)
+ let modBreaks = GHC.modInfoModBreaks mod_info
+ let ticks = modBreaks_ticks modBreaks
+ io $ displayBreakInfo session ticks info
+ io $ extendEnvironment session apStack (breakInfo_vars info)
+ pushResume resume
+ return Nothing
+
+displayBreakInfo :: Session -> Array Int SrcSpan -> BreakInfo -> IO ()
+displayBreakInfo session ticks info = do
+ unqual <- GHC.getPrintUnqual session
+ let location = ticks ! breakInfo_number info
+ printForUser stdout unqual $
+ ptext SLIT("Stopped at") <+> ppr location $$ localsMsg
+ where
+ vars = map fst $ breakInfo_vars info
+ localsMsg = if null vars
+ then text "No locals in scope."
+ else text "Locals:" <+> (pprWithCommas showId vars)
+ showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
+
+-- Todo: turn this into a primop, and provide special version(s) for unboxed things
+foreign import ccall "rts_getApStackVal" getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
+
+getIdValFromApStack :: a -> (Id, Int) -> IO (Id, HValue)
+getIdValFromApStack apStack (identifier, stackDepth) = do
+ -- ToDo: check the type of the identifer and decide whether it is unboxed or not
+ apSptr <- newStablePtr apStack
+ resultSptr <- getApStackVal apSptr (stackDepth - 1)
+ result <- deRefStablePtr resultSptr
+ freeStablePtr apSptr
+ freeStablePtr resultSptr
+ return (identifier, unsafeCoerce# result)
+
+extendEnvironment :: Session -> a -> [(Id, Int)] -> IO ()
+extendEnvironment s@(Session ref) apStack idsOffsets = do
+ idsVals <- mapM (getIdValFromApStack apStack) idsOffsets
+ let (ids, hValues) = unzip idsVals
+ let names = map idName ids
+ let global_ids = map globaliseAndTidy ids
+ typed_ids <- mapM instantiateIdType global_ids
+ hsc_env <- readIORef ref
+ let ictxt = hsc_IC hsc_env
+ rn_env = ic_rn_local_env ictxt
+ type_env = ic_type_env ictxt
+ bound_names = map idName typed_ids
+ new_rn_env = extendLocalRdrEnv rn_env bound_names
+ -- Remove any shadowed bindings from the type_env;
+ -- they are inaccessible but might, I suppose, cause
+ -- a space leak if we leave them there
+ shadowed = [ n | name <- bound_names,
+ let rdr_name = mkRdrUnqual (nameOccName name),
+ Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
+ filtered_type_env = delListFromNameEnv type_env shadowed
+ new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
+ new_ic = ictxt { ic_rn_local_env = new_rn_env,
+ ic_type_env = new_type_env }
+ writeIORef ref (hsc_env { hsc_IC = new_ic })
+ extendLinkEnv (zip names hValues) -- ToDo: we must remember to restore the old env after we finish a breakpoint
+ where
+ globaliseAndTidy :: Id -> Id
+ globaliseAndTidy id
+ = let tidied_type = tidyTopType$ idType id
+ in setIdType (globaliseId VanillaGlobal id) tidied_type
+
+ -- | Instantiate the tyVars with GHC.Base.Unknown
+ instantiateIdType :: Id -> IO Id
+ instantiateIdType id = do
+ instantiatedType <- instantiateTyVarsToUnknown s (idType id)
+ return$ setIdType id instantiatedType
-- possibly print the type and revert CAFs after evaluating an expression
finishEvalExpr mb_names
Nothing -> return ()
Just thing -> showTyThing thing
-showForUser :: SDoc -> GHCi String
-showForUser doc = do
- session <- getSession
- unqual <- io (GHC.getPrintUnqual session)
- return $! showSDocForUser unqual doc
-
specialCommand :: String -> GHCi Bool
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
specialCommand str = do
c:_ -> return (Just c)
-----------------------------------------------------------------------------
--- To flush buffers for the *interpreted* computation we need
--- to refer to *its* stdout/stderr handles
-
-GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
-GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
-
-no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
- " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
-flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
-
-initInterpBuffering :: Session -> IO ()
-initInterpBuffering session
- = do maybe_hval <- GHC.compileExpr session no_buf_cmd
-
- case maybe_hval of
- Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
- other -> panic "interactiveUI:setBuffering"
-
- maybe_hval <- GHC.compileExpr session flush_cmd
- case maybe_hval of
- Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
- _ -> panic "interactiveUI:flush"
-
- return ()
-
-
-flushInterpBuffers :: GHCi ()
-flushInterpBuffers
- = io $ do Monad.join (readIORef flush_interp)
- return ()
-
-turnOffBuffering :: IO ()
-turnOffBuffering
- = do Monad.join (readIORef turn_off_buffering)
- return ()
-
------------------------------------------------------------------------------
-- Commands
help :: String -> GHCi ()
graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
setContextAfterLoad session graph'
modulesLoadedMsg ok (map GHC.ms_mod_name graph')
-#if defined(GHCI) && defined(BREAKPOINT)
- io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
- ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
-#endif
setContextAfterLoad session [] = do
prel_mod <- getPrelude
Nothing -> return ()
Just ty -> do tystr <- showForUser (ppr ty)
io (putStrLn (str ++ " :: " ++ tystr))
-
+
quit :: String -> GHCi Bool
quit _ = return True
["modules" ] -> showModules
["bindings"] -> showBindings
["linker"] -> io showLinkerState
+ ["breaks"] -> showBkptTable
_ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
showModules = do
then return ty
else return $! GHC.dropForAlls ty
+showBkptTable :: GHCi ()
+showBkptTable = do
+ activeBreaks <- getActiveBreakPoints
+ str <- showForUser $ ppr activeBreaks
+ io $ putStrLn str
+
-- -----------------------------------------------------------------------------
-- Completion
getCommonPrefix :: [String] -> String
getCommonPrefix [] = ""
getCommonPrefix (s:ss) = foldl common s ss
- where common s "" = s
+ where common s "" = ""
common "" s = ""
common (c:cs) (d:ds)
| c == d = c : common cs ds
completeSetOptions = completeNone
completeFilename = completeNone
completeHomeModuleOrFile=completeNone
+completeBkpt = completeNone
#endif
------------------------------------------------------------------------------
--- GHCi monad
-
-data GHCiState = GHCiState
- {
- progname :: String,
- args :: [String],
- prompt :: String,
- editor :: String,
- session :: GHC.Session,
- options :: [GHCiOption],
- prelude :: Module
- }
-
-data GHCiOption
- = ShowTiming -- show time/allocs after evaluation
- | ShowType -- show the type of expressions
- | RevertCAFs -- revert CAFs after every evaluation
- deriving Eq
-
-newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
-
-startGHCi :: GHCi a -> GHCiState -> IO a
-startGHCi g state = do ref <- newIORef state; unGHCi g ref
-
-instance Monad GHCi where
- (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
- return a = GHCi $ \s -> return a
-
-ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
-ghciHandleDyn h (GHCi m) = GHCi $ \s ->
- Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
-
-getGHCiState = GHCi $ \r -> readIORef r
-setGHCiState s = GHCi $ \r -> writeIORef r s
-
--- for convenience...
-getSession = getGHCiState >>= return . session
-getPrelude = getGHCiState >>= return . prelude
-
-GLOBAL_VAR(saved_sess, no_saved_sess, Session)
-no_saved_sess = error "no saved_ses"
-saveSession = getSession >>= io . writeIORef saved_sess
-splatSavedSession = io (writeIORef saved_sess no_saved_sess)
-restoreSession = readIORef saved_sess
-
-getDynFlags = do
- s <- getSession
- io (GHC.getSessionDynFlags s)
-setDynFlags dflags = do
- s <- getSession
- io (GHC.setSessionDynFlags s dflags)
+-- ---------------------------------------------------------------------------
+-- User code exception handling
-isOptionSet :: GHCiOption -> GHCi Bool
-isOptionSet opt
- = do st <- getGHCiState
- return (opt `elem` options st)
+-- This is the exception handler for exceptions generated by the
+-- user's code and exceptions coming from children sessions;
+-- it normally just prints out the exception. The
+-- handler must be recursive, in case showing the exception causes
+-- more exceptions to be raised.
+--
+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,
+-- raising another exception. We therefore don't put the recursive
+-- handler arond the flushing operation, so if stderr is closed
+-- GHCi will just die gracefully rather than going into an infinite loop.
+handler :: Exception -> GHCi Bool
-setOption :: GHCiOption -> GHCi ()
-setOption opt
- = do st <- getGHCiState
- setGHCiState (st{ options = opt : filter (/= opt) (options st) })
+handler exception = do
+ flushInterpBuffers
+ io installSignalHandlers
+ ghciHandle handler (showException exception >> return False)
-unsetOption :: GHCiOption -> GHCi ()
-unsetOption opt
- = do st <- getGHCiState
- setGHCiState (st{ options = filter (/= opt) (options st) })
+showException (DynException dyn) =
+ case fromDynamic dyn of
+ Nothing -> io (putStrLn ("*** Exception: (unknown)"))
+ Just Interrupted -> io (putStrLn "Interrupted.")
+ Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
+ Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
+ Just other_ghc_ex -> io (print other_ghc_ex)
-io :: IO a -> GHCi a
-io m = GHCi { unGHCi = \s -> m >>= return }
+showException other_exception
+ = io (putStrLn ("*** Exception: " ++ show other_exception))
-----------------------------------------------------------------------------
-- recursive exception handlers
ghciUnblock :: GHCi a -> GHCi a
ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
------------------------------------------------------------------------------
--- timing & statistics
-
-timeIt :: GHCi a -> GHCi a
-timeIt action
- = do b <- isOptionSet ShowTiming
- if not b
- then action
- else do allocs1 <- io $ getAllocations
- time1 <- io $ getCPUTime
- a <- action
- allocs2 <- io $ getAllocations
- time2 <- io $ getCPUTime
- io $ printTimes (fromIntegral (allocs2 - allocs1))
- (time2 - time1)
- return a
-
-foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
- -- defined in ghc/rts/Stats.c
-
-printTimes :: Integer -> Integer -> IO ()
-printTimes allocs psecs
- = do let secs = (fromIntegral psecs / (10^12)) :: Float
- secs_str = showFFloat (Just 2) secs
- putStrLn (showSDoc (
- parens (text (secs_str "") <+> text "secs" <> comma <+>
- text (show allocs) <+> text "bytes")))
-
------------------------------------------------------------------------------
--- reverting CAFs
-
-revertCAFs :: IO ()
-revertCAFs = do
- rts_revertCAFs
- turnOffBuffering
- -- Have to turn off buffering again, because we just
- -- reverted stdout, stderr & stdin to their defaults.
-
-foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
- -- Make it "safe", just in case
-- ----------------------------------------------------------------------------
-- Utils
setConsoleOutputCP 28591 -- ISO Latin-1
#endif
return ()
+
+-- commands for debugger
+foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
+
+stepCmd :: String -> GHCi Bool
+stepCmd [] = doContinue setStepFlag
+stepCmd expression = do
+ io $ setStepFlag
+ runCommand expression
+
+continueCmd :: String -> GHCi Bool
+continueCmd [] = doContinue $ return ()
+continueCmd other = do
+ io $ putStrLn "The continue command accepts no arguments."
+ return False
+
+doContinue :: IO () -> GHCi Bool
+doContinue actionBeforeCont = do
+ resumeAction <- getResume
+ popResume
+ case resumeAction of
+ Nothing -> do
+ io $ putStrLn "There is no computation running."
+ return False
+ Just action -> do
+ io $ actionBeforeCont
+ runResult <- io action
+ names <- switchOnRunResult runResult
+ finishEvalExpr names
+ return False
+
+deleteCmd :: String -> GHCi Bool
+deleteCmd argLine = do
+ deleteSwitch $ words argLine
+ return False
+ where
+ deleteSwitch :: [String] -> GHCi ()
+ deleteSwitch [] =
+ io $ putStrLn "The delete command requires at least one argument."
+ -- delete all break points
+ deleteSwitch ("*":_rest) = clearActiveBreakPoints
+ deleteSwitch idents = do
+ mapM_ deleteOneBreak idents
+ where
+ deleteOneBreak :: String -> GHCi ()
+ deleteOneBreak str
+ | all isDigit str = deleteBreak (read str)
+ | otherwise = return ()
+
+-- handle the "break" command
+breakCmd :: String -> GHCi Bool
+breakCmd argLine = do
+ session <- getSession
+ breakSwitch session $ words argLine
+
+breakSwitch :: Session -> [String] -> GHCi Bool
+breakSwitch _session [] = do
+ io $ putStrLn "The break command requires at least one argument."
+ return False
+breakSwitch session args@(arg1:rest)
+ | looksLikeModule arg1 = do
+ mod <- lookupModule session arg1
+ breakByModule mod rest
+ return False
+ | otherwise = do
+ (toplevel, _) <- io $ GHC.getContext session
+ case toplevel of
+ (mod : _) -> breakByModule mod args
+ [] -> do
+ io $ putStrLn "Cannot find default module for breakpoint."
+ io $ putStrLn "Perhaps no modules are loaded for debugging?"
+ return False
+ where
+ -- Todo there may be a nicer way to test this
+ looksLikeModule :: String -> Bool
+ looksLikeModule [] = False
+ looksLikeModule (x:_) = isUpper x
+
+breakByModule :: Module -> [String] -> GHCi ()
+breakByModule mod args@(arg1:rest)
+ | all isDigit arg1 = do -- looks like a line number
+ breakByModuleLine mod (read arg1) rest
+ | looksLikeVar arg1 = do
+ -- break by a function definition
+ io $ putStrLn "Break by function definition not implemented."
+ | otherwise = io $ putStrLn "Invalid arguments to break command."
+ where
+ -- Todo there may be a nicer way to test this
+ looksLikeVar :: String -> Bool
+ looksLikeVar [] = False
+ looksLikeVar (x:_) = isLower x || x `elem` "~!@#$%^&*-+"
+
+breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
+breakByModuleLine mod line args
+ | [] <- args = findBreakAndSet mod $ lookupTickTreeLine line
+ | [col] <- args, all isDigit col =
+ findBreakAndSet mod $ lookupTickTreeCoord (line, read col)
+ | otherwise = io $ putStrLn "Invalid arguments to break command."
+
+findBreakAndSet :: Module -> (TickTree -> Maybe (Int, SrcSpan)) -> GHCi ()
+findBreakAndSet mod lookupTickTree = do
+ (breakArray, ticks) <- getModBreak mod
+ let tickTree = tickTreeFromList (assocs ticks)
+ case lookupTickTree tickTree of
+ Nothing -> io $ putStrLn $ "No breakpoints found at that location."
+ Just (tick, span) -> do
+ success <- io $ setBreakFlag True breakArray tick
+ session <- getSession
+ unqual <- io $ GHC.getPrintUnqual session
+ if success
+ then do
+ (alreadySet, nm) <-
+ recordBreak $ BreakLocation
+ { breakModule = mod
+ , breakLoc = span
+ , breakTick = tick
+ }
+ io $ printForUser stdout unqual $
+ text "Breakpoint " <> ppr nm <>
+ if alreadySet
+ then text " was already set at " <> ppr span
+ else text " activated at " <> ppr span
+ else do
+ str <- showForUser $ text "Breakpoint could not be activated at"
+ <+> ppr span
+ io $ putStrLn str
+
+getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan)
+getModBreak mod = do
+ session <- getSession
+ Just mod_info <- io $ GHC.getModuleInfo session mod
+ let modBreaks = GHC.modInfoModBreaks mod_info
+ let array = modBreaks_array modBreaks
+ let ticks = modBreaks_ticks modBreaks
+ return (array, ticks)
+
+lookupModule :: Session -> String -> GHCi Module
+lookupModule session modName
+ = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
+
+setBreakFlag :: Bool -> BreakArray -> Int -> IO Bool
+setBreakFlag toggle array index
+ | toggle = setBreakOn array index
+ | otherwise = setBreakOff array index
+
+
+{- these should probably go to the GHC API at some point -}
+enableBreakPoint :: Session -> Module -> Int -> IO ()
+enableBreakPoint session mod index = return ()
+
+disableBreakPoint :: Session -> Module -> Int -> IO ()
+disableBreakPoint session mod index = return ()
+
+activeBreakPoints :: Session -> IO [(Module,Int)]
+activeBreakPoints session = return []
+
+enableSingleStep :: Session -> IO ()
+enableSingleStep session = return ()
+
+disableSingleStep :: Session -> IO ()
+disableSingleStep session = return ()
projects / ghc-hetmet.git / blobdiff