modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
-#if defined(GHCI)
- modInfoBkptSites,
-#endif
lookupGlobalName,
-- * Printing
exprType,
typeKind,
parseName,
- RunResult(..),
+ RunResult(..), ResumeHandle,
runStmt,
+ resume,
showModule,
isModuleInterpreted,
compileExpr, HValue, dynCompileExpr,
lookupName,
-
- getBreakpointHandler, setBreakpointHandler,
obtainTerm, obtainTerm1,
+ ModBreaks(..), BreakIndex,
+ BreakInfo(breakInfo_number, breakInfo_module),
+ modInfoModBreaks,
#endif
-- * Abstract syntax elements
import RtClosureInspect ( cvObtainTerm, Term )
import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo,
tcRnLookupName, getModuleExports )
-import RdrName ( plusGlobalRdrEnv, Provenance(..),
- ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
- mkGlobalRdrEnv )
-import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
-import Name ( nameOccName )
-import Type ( tidyType )
-import Var ( varName )
import VarEnv ( emptyTidyEnv )
-import GHC.Exts ( unsafeCoerce# )
-
--- For breakpoints
-import Breakpoints ( SiteNumber, Coord, nullBkptHandler,
- BkptHandler(..), BkptLocation, noDbgSites )
-import Linker ( initDynLinker )
-import PrelNames ( breakpointJumpName, breakpointCondJumpName,
- breakpointAutoJumpName )
-
-import GHC.Exts ( Int(..), Ptr(..), int2Addr#, indexArray# )
-import GHC.Base ( Opaque(..) )
-import Foreign.StablePtr( deRefStablePtr, castPtrToStablePtr )
-import Foreign ( unsafePerformIO )
-import Data.Maybe ( fromMaybe)
+import GHC.Exts ( unsafeCoerce#, Ptr )
+import Foreign.StablePtr( deRefStablePtr, StablePtr, newStablePtr, freeStablePtr )
+import Foreign ( poke )
import qualified Linker
import Data.Dynamic ( Dynamic )
import Linker ( HValue, getHValue, extendLinkEnv )
+
+import ByteCodeInstr
+import DebuggerTys
+import IdInfo
+import HscMain ( hscParseIdentifier, hscTcExpr, hscKcType, hscStmt )
#endif
-import Packages ( initPackages )
-import NameSet ( NameSet, nameSetToList, elemNameSet )
-import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
- globalRdrEnvElts, extendGlobalRdrEnv,
- emptyGlobalRdrEnv )
+import Packages
+import NameSet
+import RdrName
import HsSyn
-import Type ( Kind, Type, dropForAlls, PredType, ThetaType,
- pprThetaArrow, pprParendType, splitForAllTys,
- pprTypeApp, funResultTy )
-import Id ( Id, idType, isImplicitId, isDeadBinder,
- isExportedId, isLocalId, isGlobalId,
- isRecordSelector, recordSelectorFieldLabel,
- isPrimOpId, isFCallId, isClassOpId_maybe,
- isDataConWorkId, idDataCon,
- isBottomingId )
-import Var ( TyVar )
+import Type hiding (typeKind)
+import Id
+import Var hiding (setIdType)
import TysPrim ( alphaTyVars )
-import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
- isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity,
- tyConTyVars, tyConDataCons, synTyConDefn,
- synTyConType, synTyConResKind )
-import Class ( Class, classSCTheta, classTvsFds, classMethods )
-import FunDeps ( pprFundeps )
-import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
- dataConFieldLabels, dataConStrictMarks,
- dataConIsInfix, isVanillaDataCon )
-import Name ( Name, nameModule, NamedThing(..), nameSrcLoc )
+import TyCon
+import Class
+import FunDeps
+import DataCon
+import Name hiding ( varName )
import OccName ( parenSymOcc )
-import NameEnv ( nameEnvElts )
+import NameEnv
import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
import SrcLoc
import DriverPipeline
import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
import HeaderInfo ( getImports, getOptions )
import Finder
-import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
+import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
import HscTypes
import DynFlags
import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
cleanTempDirs )
import Module
import UniqFM
-import PackageConfig ( PackageId, stringToPackageId, mainPackageId )
+import PackageConfig
import FiniteMap
import Panic
import Digraph
import BasicTypes
import TcType ( tcSplitSigmaTy, isDictTy )
import Maybes ( expectJust, mapCatMaybes )
-import HaddockParse ( parseHaddockParagraphs, parseHaddockString )
+import HaddockParse
import HaddockLex ( tokenise )
import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist )
-import Data.Maybe ( isJust, isNothing )
-import Data.List ( partition, nub )
+import Data.Maybe
+import Data.List
import qualified Data.List as List
-import Control.Monad ( unless, when )
+import Control.Monad
import System.Exit ( exitWith, ExitCode(..) )
import System.Time ( ClockTime )
import Control.Exception as Exception hiding (handle)
minf_rdr_env = Just rdr_env,
minf_instances = md_insts details
#ifdef GHCI
- ,minf_dbg_sites = noDbgSites
+ ,minf_modBreaks = emptyModBreaks
#endif
}
return (Just (CheckedModule {
minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
minf_instances :: [Instance]
#ifdef GHCI
- ,minf_dbg_sites :: [(SiteNumber,Coord)]
+ ,minf_modBreaks :: ModBreaks
#endif
-- ToDo: this should really contain the ModIface too
}
minf_exports = names,
minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
minf_instances = error "getModuleInfo: instances for package module unimplemented",
- minf_dbg_sites = noDbgSites
+ minf_modBreaks = emptyModBreaks
}))
#else
-- bogusly different for non-GHCI (ToDo)
minf_rdr_env = mi_globals $! hm_iface hmi,
minf_instances = md_insts details
#ifdef GHCI
- ,minf_dbg_sites = md_dbg_sites details
+ ,minf_modBreaks = md_modBreaks details
#endif
}))
(hsc_HPT hsc_env) (eps_PTE eps) name
#ifdef GHCI
-modInfoBkptSites = minf_dbg_sites
+modInfoModBreaks = minf_modBreaks
#endif
isDictonaryId :: Id -> Bool
writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
ic_exports = export_mods,
ic_rn_gbl_env = all_env }}
- reinstallBreakpointHandlers sess
-- Make a GlobalRdrEnv based on the exports of the modules only.
mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
= RunOk [Name] -- ^ names bound by this evaluation
| RunFailed -- ^ statement failed compilation
| RunException Exception -- ^ statement raised an exception
+ | RunBreak ThreadId [Name] BreakInfo ResumeHandle
+
+data Status
+ = Break HValue BreakInfo ThreadId ResumeHandle -- ^ the computation hit a breakpoint
+ | Complete (Either Exception [HValue]) -- ^ the computation completed with either an exception or a value
+
+data ResumeHandle = ResumeHandle (MVar ()) (MVar Status) [Name]
--- | Run a statement in the current interactive context. Statemenet
+-- | Run a statement in the current interactive context. Statement
-- may bind multple values.
runStmt :: Session -> String -> IO RunResult
runStmt (Session ref) expr
= do
hsc_env <- readIORef ref
+ breakMVar <- newEmptyMVar -- wait on this when we hit a breakpoint
+ statusMVar <- newEmptyMVar -- wait on this when a computation is running
+
-- Turn off -fwarn-unused-bindings when running a statement, to hide
-- warnings about the implicit bindings we introduce.
let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
case maybe_stuff of
Nothing -> return RunFailed
Just (new_hsc_env, names, hval) -> do
-
- let thing_to_run = unsafeCoerce# hval :: IO [HValue]
- either_hvals <- sandboxIO thing_to_run
-
+ writeIORef ref new_hsc_env
+
+ let resume_handle = ResumeHandle breakMVar statusMVar names
+ -- set the onBreakAction to be performed when we hit a
+ -- breakpoint this is visible in the Byte Code
+ -- Interpreter, thus it is a global variable,
+ -- implemented with stable pointers
+ stablePtr <- setBreakAction resume_handle
+
+ let thing_to_run = unsafeCoerce# hval :: IO [HValue]
+ status <- sandboxIO statusMVar thing_to_run
+ freeStablePtr stablePtr -- be careful not to leak stable pointers!
+ handleRunStatus ref names status
+
+handleRunStatus ref names status =
+ case status of
+ -- did we hit a breakpoint or did we complete?
+ (Break apStack info tid res) -> do
+ hsc_env <- readIORef ref
+ (new_hsc_env, names) <- extendEnvironment hsc_env apStack
+ (breakInfo_vars info)
+ writeIORef ref new_hsc_env
+ return (RunBreak tid names info res)
+ (Complete either_hvals) ->
case either_hvals of
- Left e -> do
- -- on error, keep the *old* interactive context,
- -- so that 'it' is not bound to something
- -- that doesn't exist.
- return (RunException e)
-
+ Left e -> return (RunException e)
Right hvals -> do
- -- Get the newly bound things, and bind them.
- -- Don't need to delete any shadowed bindings;
- -- the new ones override the old ones.
extendLinkEnv (zip names hvals)
-
- writeIORef ref new_hsc_env
return (RunOk names)
+
+-- this points to the IO action that is executed when a breakpoint is hit
+foreign import ccall "&breakPointIOAction"
+ breakPointIOAction :: Ptr (StablePtr (BreakInfo -> HValue -> IO ()))
-- When running a computation, we redirect ^C exceptions to the running
-- thread. ToDo: we might want a way to continue even if the target
-- thread doesn't die when it receives the exception... "this thread
-- is not responding".
-sandboxIO :: IO a -> IO (Either Exception a)
-sandboxIO thing = do
- m <- newEmptyMVar
+sandboxIO :: MVar Status -> IO [HValue] -> IO Status
+sandboxIO statusMVar thing = do
ts <- takeMVar interruptTargetThread
- child <- forkIO (do res <- Exception.try thing; putMVar m res)
+ child <- forkIO (do res <- Exception.try thing; putMVar statusMVar (Complete res))
putMVar interruptTargetThread (child:ts)
- takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
+ takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail)
+
+setBreakAction res@(ResumeHandle breakMVar statusMVar names) = do
+ stablePtr <- newStablePtr onBreak
+ poke breakPointIOAction stablePtr
+ return stablePtr
+ where onBreak ids apStack = do
+ tid <- myThreadId
+ putMVar statusMVar (Break apStack ids tid res)
+ takeMVar breakMVar
+
+resume :: Session -> ResumeHandle -> IO RunResult
+resume (Session ref) res@(ResumeHandle breakMVar statusMVar names) = do
+ stablePtr <- setBreakAction res
+ putMVar breakMVar ()
+ status <- takeMVar statusMVar
+ handleRunStatus ref names status
{-
-- This version of sandboxIO runs the expression in a completely new
-}
+-- -----------------------------------------------------------------------------
+-- After stopping at a breakpoint, add free variables to the environment
+
+-- 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 :: HscEnv -> a -> [(Id, Int)] -> IO (HscEnv, [Name])
+extendEnvironment hsc_env 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
+ 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 }
+ extendLinkEnv (zip names hValues) -- ToDo: we must remember to restore the old env after we finish a breakpoint
+ return (hsc_env{hsc_IC = new_ic}, names)
+ 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 hsc_env (idType id)
+ return$ setIdType id instantiatedType
-----------------------------------------------------------------------------
-- show a module and it's source/object filenames
where
obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
------------------------------------------------------------------------------
--- Breakpoint handlers
-
-getBreakpointHandler :: Session -> IO (Maybe (BkptHandler Module))
-getBreakpointHandler session = getSessionDynFlags session >>= return . bkptHandler
-
-setBreakpointHandler :: Session -> BkptHandler Module -> IO ()
-setBreakpointHandler session handler = do
- dflags <- getSessionDynFlags session
- setSessionDynFlags session dflags{ bkptHandler = Just handler }
- let linkEnv = [ ( breakpointJumpName
- , unsafeCoerce# (jumpFunction session handler))
- , ( breakpointCondJumpName
- , unsafeCoerce# (jumpCondFunction session handler))
- , ( breakpointAutoJumpName
- , unsafeCoerce# (jumpAutoFunction session handler))
- ]
- writeIORef v_bkptLinkEnv linkEnv
- dflags <- getSessionDynFlags session
- reinstallBreakpointHandlers session
-
-reinstallBreakpointHandlers :: Session -> IO ()
-reinstallBreakpointHandlers session = do
- dflags <- getSessionDynFlags session
- let mode = ghcMode dflags
- when (ghcLink dflags == LinkInMemory) $ do
- linkEnv <- readIORef v_bkptLinkEnv
- initDynLinker dflags
- extendLinkEnv linkEnv
-
------------------------------------------------------------------------
--- Jump functions
-
-type SiteInfo = (String, SiteNumber)
-jumpFunction, jumpAutoFunction :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> b -> b
-jumpCondFunction :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> Bool -> b -> b
-jumpFunctionM :: Session -> BkptHandler a -> BkptLocation a -> (Int, [Opaque], String) -> b -> IO b
-
-jumpCondFunction _ _ _ _ False b = b
-jumpCondFunction session handler site args True b
- = jumpFunction session handler site args b
-
-jumpFunction session handler siteInfo args b
- | site <- mkSite siteInfo
- = unsafePerformIO $ jumpFunctionM session handler site args b
-
-jumpFunctionM session handler site (I# idsPtr, wrapped_hValues, locmsg) b =
- do
- ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
- let hValues = unsafeCoerce# b : [unsafeCoerce# hv | O hv <- wrapped_hValues]
- handleBreakpoint handler session (zip ids hValues) site locmsg b
-
-jumpAutoFunction session handler siteInfo args b
- | site <- mkSite siteInfo
- = unsafePerformIO $ do
- break <- isAutoBkptEnabled handler session site
- if break
- then jumpFunctionM session handler site args b
- else return b
-
-jumpStepByStepFunction session handler siteInfo args b
- | site <- mkSite siteInfo
- = unsafePerformIO $ do
- jumpFunctionM session handler site args b
-
-mkSite :: SiteInfo -> BkptLocation Module
-mkSite ( modName, sitenum) =
- (mkModule mainPackageId (mkModuleName modName), sitenum)
-
obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
projects / ghc-hetmet.git / blobdiff