summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/BreakArray.hs83
-rw-r--r--compiler/main/DynFlags.hs11
-rw-r--r--compiler/main/GHC.hs3
-rw-r--r--compiler/main/HscTypes.hs16
-rw-r--r--compiler/main/InteractiveEval.hs34
-rw-r--r--compiler/main/InteractiveEvalTypes.hs13
6 files changed, 93 insertions, 67 deletions
diff --git a/compiler/main/BreakArray.hs b/compiler/main/BreakArray.hs
index 9b84931390..447490266c 100644
--- a/compiler/main/BreakArray.hs
+++ b/compiler/main/BreakArray.hs
@@ -2,13 +2,16 @@
-------------------------------------------------------------------------------
--
--- | Break Arrays in the IO monad
+-- (c) The University of Glasgow 2007
--
--- Entries in the array are Word sized Conceptually, a zero-indexed IOArray of
--- Bools, initially False. They're represented as Words with 0==False, 1==True.
--- They're used to determine whether GHCI breakpoints are on or off.
+-- | Break Arrays
--
--- (c) The University of Glasgow 2007
+-- An array of bytes, indexed by a breakpoint number (breakpointId in Tickish)
+-- There is one of these arrays per module.
+--
+-- Each byte is
+-- 1 if the corresponding breakpoint is enabled
+-- 0 otherwise
--
-------------------------------------------------------------------------------
@@ -27,10 +30,10 @@ module BreakArray
#endif
) where
-import DynFlags
-
#ifdef GHCI
import Control.Monad
+import Data.Word
+import GHC.Word
import GHC.Exts
import GHC.IO ( IO(..) )
@@ -38,43 +41,43 @@ import System.IO.Unsafe ( unsafeDupablePerformIO )
data BreakArray = BA (MutableByteArray# RealWorld)
-breakOff, breakOn :: Word
+breakOff, breakOn :: Word8
breakOn = 1
breakOff = 0
-showBreakArray :: DynFlags -> BreakArray -> IO ()
-showBreakArray dflags array = do
- forM_ [0 .. (size dflags array - 1)] $ \i -> do
+showBreakArray :: BreakArray -> IO ()
+showBreakArray array = do
+ forM_ [0 .. (size array - 1)] $ \i -> do
val <- readBreakArray array i
putStr $ ' ' : show val
putStr "\n"
-setBreakOn :: DynFlags -> BreakArray -> Int -> IO Bool
-setBreakOn dflags array index
- | safeIndex dflags array index = do
+setBreakOn :: BreakArray -> Int -> IO Bool
+setBreakOn array index
+ | safeIndex array index = do
writeBreakArray array index breakOn
return True
| otherwise = return False
-setBreakOff :: DynFlags -> BreakArray -> Int -> IO Bool
-setBreakOff dflags array index
- | safeIndex dflags array index = do
+setBreakOff :: BreakArray -> Int -> IO Bool
+setBreakOff array index
+ | safeIndex array index = do
writeBreakArray array index breakOff
return True
| otherwise = return False
-getBreak :: DynFlags -> BreakArray -> Int -> IO (Maybe Word)
-getBreak dflags array index
- | safeIndex dflags array index = do
+getBreak :: BreakArray -> Int -> IO (Maybe Word8)
+getBreak array index
+ | safeIndex array index = do
val <- readBreakArray array index
return $ Just val
| otherwise = return Nothing
-safeIndex :: DynFlags -> BreakArray -> Int -> Bool
-safeIndex dflags array index = index < size dflags array && index >= 0
+safeIndex :: BreakArray -> Int -> Bool
+safeIndex array index = index < size array && index >= 0
-size :: DynFlags -> BreakArray -> Int
-size dflags (BA array) = size `div` wORD_SIZE dflags
+size :: BreakArray -> Int
+size (BA array) = size
where
-- We want to keep this operation pure. The mutable byte array
-- is never resized so this is safe.
@@ -90,30 +93,28 @@ allocBA (I# sz) = IO $ \s1 ->
case newByteArray# sz s1 of { (# s2, array #) -> (# s2, BA array #) }
-- create a new break array and initialise elements to zero
-newBreakArray :: DynFlags -> Int -> IO BreakArray
-newBreakArray dflags entries@(I# sz) = do
- BA array <- allocBA (entries * wORD_SIZE dflags)
+newBreakArray :: Int -> IO BreakArray
+newBreakArray entries@(I# sz) = do
+ BA array <- allocBA entries
case breakOff of
- W# off -> do -- Todo: there must be a better way to write zero as a Word!
- let loop n | isTrue# (n ==# sz) = return ()
- | otherwise = do
- writeBA# array n off
- loop (n +# 1#)
- loop 0#
+ W8# off -> do
+ let loop n | isTrue# (n ==# sz) = return ()
+ | otherwise = do writeBA# array n off; loop (n +# 1#)
+ loop 0#
return $ BA array
writeBA# :: MutableByteArray# RealWorld -> Int# -> Word# -> IO ()
writeBA# array i word = IO $ \s ->
- case writeWordArray# array i word s of { s -> (# s, () #) }
+ case writeWord8Array# array i word s of { s -> (# s, () #) }
-writeBreakArray :: BreakArray -> Int -> Word -> IO ()
-writeBreakArray (BA array) (I# i) (W# word) = writeBA# array i word
+writeBreakArray :: BreakArray -> Int -> Word8 -> IO ()
+writeBreakArray (BA array) (I# i) (W8# word) = writeBA# array i word
-readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word
+readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word8
readBA# array i = IO $ \s ->
- case readWordArray# array i s of { (# s, c #) -> (# s, W# c #) }
+ case readWord8Array# array i s of { (# s, c #) -> (# s, W8# c #) }
-readBreakArray :: BreakArray -> Int -> IO Word
+readBreakArray :: BreakArray -> Int -> IO Word8
readBreakArray (BA array) (I# i) = readBA# array i
#else /* !GHCI */
@@ -124,8 +125,8 @@ readBreakArray (BA array) (I# i) = readBA# array i
-- presumably have a different representation.
data BreakArray = Unspecified
-newBreakArray :: DynFlags -> Int -> IO BreakArray
-newBreakArray _ _ = return Unspecified
+newBreakArray :: Int -> IO BreakArray
+newBreakArray _ = return Unspecified
#endif /* GHCI */
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index a23ecfa8d3..556175c0ea 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -81,6 +81,7 @@ module DynFlags (
defaultDynFlags, -- Settings -> DynFlags
defaultWays,
interpWays,
+ interpreterProfiled, interpreterDynamic,
initDynFlags, -- DynFlags -> IO DynFlags
defaultFatalMessager,
defaultLogAction,
@@ -1522,6 +1523,16 @@ interpWays
| rtsIsProfiled = [WayProf]
| otherwise = []
+interpreterProfiled :: DynFlags -> Bool
+interpreterProfiled dflags
+ | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
+ | otherwise = rtsIsProfiled
+
+interpreterDynamic :: DynFlags -> Bool
+interpreterDynamic dflags
+ | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags
+ | otherwise = dynamicGhc
+
--------------------------------------------------------------------------
type FatalMessager = String -> IO ()
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 4bf9a5845f..0ac1331d26 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -136,8 +136,7 @@ module GHC (
-- ** The debugger
SingleStep(..),
- Resume(resumeStmt, resumeBreakInfo, resumeSpan,
- resumeHistory, resumeHistoryIx),
+ Resume(..),
History(historyBreakInfo, historyEnclosingDecls),
GHC.getHistorySpan, getHistoryModule,
abandon, abandonAll,
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 3766b57df1..ea921fe79a 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -112,6 +112,7 @@ module HscTypes (
-- * Breakpoints
ModBreaks (..), BreakIndex, emptyModBreaks,
+ CCostCentre,
-- * Vectorisation information
VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo,
@@ -136,7 +137,7 @@ module HscTypes (
import ByteCodeTypes ( CompiledByteCode )
import InteractiveEvalTypes ( Resume )
import GHCi.Message ( Pipe )
-import GHCi.RemoteTypes ( HValueRef )
+import GHCi.RemoteTypes
#endif
import HsSyn
@@ -191,15 +192,14 @@ import Platform
import Util
import GHC.Serialized ( Serialized )
+import Foreign
import Control.Monad ( guard, liftM, when, ap )
import Control.Concurrent
import Data.Array ( Array, array )
import Data.IORef
import Data.Time
-import Data.Word
import Data.Typeable ( Typeable )
import Exception
-import Foreign
import System.FilePath
import System.Process ( ProcessHandle )
@@ -2872,6 +2872,9 @@ byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other)
-- | Breakpoint index
type BreakIndex = Int
+-- | C CostCentre type
+data CCostCentre
+
-- | All the information about the breakpoints for a given module
data ModBreaks
= ModBreaks
@@ -2884,6 +2887,10 @@ data ModBreaks
-- ^ An array giving the names of the free variables at each breakpoint.
, modBreaks_decls :: !(Array BreakIndex [String])
-- ^ An array giving the names of the declarations enclosing each breakpoint.
+#ifdef GHCI
+ , modBreaks_ccs :: !(Array BreakIndex (RemotePtr {- CCostCentre -}))
+ -- ^ Array pointing to cost centre for each breakpoint
+#endif
}
-- | Construct an empty ModBreaks
@@ -2894,4 +2901,7 @@ emptyModBreaks = ModBreaks
, modBreaks_locs = array (0,-1) []
, modBreaks_vars = array (0,-1) []
, modBreaks_decls = array (0,-1) []
+#ifdef GHCI
+ , modBreaks_ccs = array (0,-1) []
+#endif
}
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 2f819e4a60..eb23a60f82 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -94,7 +94,7 @@ import qualified Parser (parseStmt, parseModule, parseDeclaration)
import System.Directory
import Data.Dynamic
import Data.Either
-import Data.List (find)
+import Data.List (find,intercalate)
import StringBuffer (stringToStringBuffer)
import Control.Monad
import GHC.Exts
@@ -293,7 +293,7 @@ handleRunStatus step expr bindings final_ids status history
| otherwise = not_tracing
where
tracing
- | EvalBreak is_exception apStack_ref info_ref resume_ctxt <- status
+ | EvalBreak is_exception apStack_ref info_ref resume_ctxt _ccs <- status
, not is_exception
= do
hsc_env <- getSession
@@ -320,7 +320,7 @@ handleRunStatus step expr bindings final_ids status history
not_tracing
-- Hit a breakpoint
- | EvalBreak is_exception apStack_ref info_ref resume_ctxt <- status
+ | EvalBreak is_exception apStack_ref info_ref resume_ctxt ccs <- status
= do
hsc_env <- getSession
let dflags = hsc_dflags hsc_env
@@ -330,7 +330,7 @@ handleRunStatus step expr bindings final_ids status history
apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
let mb_info | is_exception = Nothing
| otherwise = Just info
- (hsc_env1, names, span) <- liftIO $
+ (hsc_env1, names, span, decl) <- liftIO $
bindLocalsAtBreakpoint hsc_env apStack_fhv mb_info
let
resume = Resume
@@ -338,6 +338,8 @@ handleRunStatus step expr bindings final_ids status history
, resumeBindings = bindings, resumeFinalIds = final_ids
, resumeApStack = apStack_fhv, resumeBreakInfo = mb_info
, resumeSpan = span, resumeHistory = toListBL history
+ , resumeDecl = decl
+ , resumeCCS = ccs
, resumeHistoryIx = 0 }
hsc_env2 = pushResume hsc_env1 resume
@@ -365,8 +367,7 @@ isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
isBreakEnabled hsc_env inf =
case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
Just hmi -> do
- w <- getBreak (hsc_dflags hsc_env)
- (modBreaks_flags (getModBreaks hmi))
+ w <- getBreak (modBreaks_flags (getModBreaks hmi))
(breakInfo_number inf)
case w of Just n -> return (n /= 0); _other -> return False
_ ->
@@ -419,13 +420,13 @@ resumeExec canLogSpan step
fromListBL 50 hist
handleRunStatus step expr bindings final_ids status hist'
-back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
+back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
back n = moveHist (+n)
-forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
+forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
forward n = moveHist (subtract n)
-moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
+moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)
moveHist fn = do
hsc_env <- getSession
case ic_resume (hsc_IC hsc_env) of
@@ -443,15 +444,15 @@ moveHist fn = do
let
update_ic apStack mb_info = do
- (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
- apStack mb_info
+ (hsc_env1, names, span, decl) <-
+ liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info
let ic = hsc_IC hsc_env1
r' = r { resumeHistoryIx = new_ix }
ic' = ic { ic_resume = r':rs }
modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
- return (names, new_ix, span)
+ return (names, new_ix, span, decl)
-- careful: we want apStack to be the AP_STACK itself, not a thunk
-- around it, hence the cases are carefully constructed below to
@@ -474,7 +475,7 @@ bindLocalsAtBreakpoint
:: HscEnv
-> ForeignHValue
-> Maybe BreakInfo
- -> IO (HscEnv, [Name], SrcSpan)
+ -> IO (HscEnv, [Name], SrcSpan, String)
-- Nothing case: we stopped when an exception was raised, not at a
-- breakpoint. We have no location information or local variables to
@@ -482,7 +483,7 @@ bindLocalsAtBreakpoint
-- value.
bindLocalsAtBreakpoint hsc_env apStack Nothing = do
let exn_occ = mkVarOccFS (fsLit "_exception")
- span = mkGeneralSrcSpan (fsLit "<exception thrown>")
+ span = mkGeneralSrcSpan (fsLit "<unknown>")
exn_name <- newInteractiveBinder hsc_env exn_occ span
let e_fs = fsLit "e"
@@ -495,7 +496,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
--
Linker.extendLinkEnv [(exn_name, apStack)]
- return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
+ return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
-- Just case: we stopped at a breakpoint, we have information about the location
-- of the breakpoint and the free variables of the expression.
@@ -510,6 +511,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just info) = do
result_ty = breakInfo_resty info
occs = modBreaks_vars breaks ! index
span = modBreaks_locs breaks ! index
+ decl = intercalate "." $ modBreaks_decls breaks ! index
-- Filter out any unboxed ids;
-- we can't bind these at the prompt
@@ -556,7 +558,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just info) = do
Linker.extendLinkEnv (zip names fhvs)
when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]
hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
- return (hsc_env1, if result_ok then result_name:names else names, span)
+ return (hsc_env1, if result_ok then result_name:names else names, span, decl)
where
-- We need a fresh Unique for each Id we bind, because the linker
-- state is single-threaded and otherwise we'd spam old bindings
diff --git a/compiler/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs
index 98090bbaed..4372891bd8 100644
--- a/compiler/main/InteractiveEvalTypes.hs
+++ b/compiler/main/InteractiveEvalTypes.hs
@@ -17,7 +17,7 @@ module InteractiveEvalTypes (
#ifdef GHCI
-import GHCi.RemoteTypes (ForeignHValue)
+import GHCi.RemoteTypes
import GHCi.Message (EvalExpr)
import Id
import Name
@@ -67,9 +67,13 @@ data Resume
resumeBreakInfo :: Maybe BreakInfo,
-- the breakpoint we stopped at
-- (Nothing <=> exception)
- resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain
- -- to fetch the ModDetails & ModBreaks
- -- to get this.
+ resumeSpan :: SrcSpan, -- just a copy of the SrcSpan
+ -- from the ModBreaks,
+ -- otherwise it's a pain to
+ -- fetch the ModDetails &
+ -- ModBreaks to get this.
+ resumeDecl :: String, -- ditto
+ resumeCCS :: RemotePtr {- CostCentreStack -},
resumeHistory :: [History],
resumeHistoryIx :: Int -- 0 <==> at the top of the history
}
@@ -81,4 +85,3 @@ data History
historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint
}
#endif
-
View Lorry Controller Status