X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=a04c06c3799877cf2f8a00342f5f982fb1b69b56;hb=38e7ac3ffa32d75c1922e7247a910e06d9957116;hp=32bcf25b3a433b5ecdf02f141a516a5f9ed72641;hpb=025733b8367d9108e8992b2db3dbb9f80cad4fa9;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 32bcf25..a04c06c 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -14,7 +14,8 @@ module GHC ( newSession, -- * Flags and settings - DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt, + DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, + GhcMode(..), GhcLink(..), parseDynamicFlags, getSessionDynFlags, setSessionDynFlags, @@ -59,9 +60,6 @@ module GHC ( modInfoInstances, modInfoIsExportedName, modInfoLookupName, -#if defined(GHCI) - modInfoBkptSites, -#endif lookupGlobalName, -- * Printing @@ -79,15 +77,17 @@ module GHC ( exprType, typeKind, parseName, - RunResult(..), + RunResult(..), ResumeHandle, runStmt, + resume, showModule, isModuleInterpreted, compileExpr, HValue, dynCompileExpr, lookupName, - - getBreakpointHandler, setBreakpointHandler, - obtainTerm, + obtainTerm, obtainTerm1, + ModBreaks(..), BreakIndex, + BreakInfo(breakInfo_number, breakInfo_module), + modInfoModBreaks, #endif -- * Abstract syntax elements @@ -185,77 +185,50 @@ module GHC ( 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 ) +import PackageConfig import FiniteMap import Panic import Digraph @@ -270,15 +243,15 @@ import Outputable 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) @@ -339,9 +312,8 @@ defaultErrorHandler dflags inner = defaultCleanupHandler :: DynFlags -> IO a -> IO a defaultCleanupHandler dflags inner = -- make sure we clean up after ourselves - later (unless (dopt Opt_KeepTmpFiles dflags) $ - do cleanTempFiles dflags - cleanTempDirs dflags + later (do cleanTempFiles dflags + cleanTempDirs dflags ) -- exceptions will be blocked while we clean the temporary files, -- so there shouldn't be any difficulty if we receive further @@ -357,10 +329,8 @@ GLOBAL_VAR(v_bkptLinkEnv, [], [(Name, HValue)]) -- | Starts a new session. A session consists of a set of loaded -- modules, a set of options (DynFlags), and an interactive context. --- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed --- code". -newSession :: GhcMode -> Maybe FilePath -> IO Session -newSession mode mb_top_dir = do +newSession :: Maybe FilePath -> IO Session +newSession mb_top_dir = do -- catch ^C main_thread <- myThreadId modifyMVar_ interruptTargetThread (return . (main_thread :)) @@ -368,7 +338,7 @@ newSession mode mb_top_dir = do dflags0 <- initSysTools mb_top_dir defaultDynFlags dflags <- initDynFlags dflags0 - env <- newHscEnv dflags{ ghcMode=mode } + env <- newHscEnv dflags ref <- newIORef env return (Session ref) @@ -529,10 +499,9 @@ depanal (Session ref) excluded_mods allow_dup_roots = do old_graph = hsc_mod_graph hsc_env showPass dflags "Chasing dependencies" - when (gmode == BatchCompile) $ - debugTraceMsg dflags 2 (hcat [ - text "Chasing modules from: ", - hcat (punctuate comma (map pprTarget targets))]) + debugTraceMsg dflags 2 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots case r of @@ -611,8 +580,7 @@ load2 s@(Session ref) how_much mod_graph = do let -- check the stability property for each module. stable_mods@(stable_obj,stable_bco) - | BatchCompile <- ghci_mode = ([],[]) - | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods + = checkStability hpt1 mg2_with_srcimps all_home_mods -- prune bits of the HPT which are definitely redundant now, -- to save space. @@ -720,13 +688,16 @@ load2 s@(Session ref) how_much mod_graph = do a_root_is_Main = any ((==main_mod).ms_mod) mod_graph do_linking = a_root_is_Main || no_hs_main - when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $ - debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++ - "but no output will be generated\n" ++ - "because there is no " ++ moduleNameString (moduleName main_mod) ++ " module.")) + when (ghcLink dflags == LinkBinary + && isJust ofile && not do_linking) $ + debugTraceMsg dflags 1 $ + text ("Warning: output was redirected with -o, " ++ + "but no output will be generated\n" ++ + "because there is no " ++ + moduleNameString (moduleName main_mod) ++ " module.") -- link everything together - linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1) + linkresult <- link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) loadFinish Succeeded linkresult ref hsc_env1 @@ -756,7 +727,7 @@ load2 s@(Session ref) how_much mod_graph = do (eltsUFM (hsc_HPT hsc_env))) do -- Link everything together - linkresult <- link ghci_mode dflags False hpt4 + linkresult <- link (ghcLink dflags) dflags False hpt4 let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 } loadFinish Failed linkresult ref hsc_env4 @@ -855,7 +826,7 @@ checkModule session@(Session ref) mod = do minf_rdr_env = Just rdr_env, minf_instances = md_insts details #ifdef GHCI - ,minf_dbg_sites = noDbgSites + ,minf_modBreaks = emptyModBreaks #endif } return (Just (CheckedModule { @@ -869,15 +840,13 @@ checkModule session@(Session ref) mod = do unload :: HscEnv -> [Linkable] -> IO () unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' - = case ghcMode (hsc_dflags hsc_env) of - BatchCompile -> return () - JustTypecheck -> return () + = case ghcLink (hsc_dflags hsc_env) of #ifdef GHCI - Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables + LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables #else - Interactive -> panic "unload: no interpreter" + LinkInMemory -> panic "unload: no interpreter" #endif - other -> panic "unload: strange mode" + other -> return () -- ----------------------------------------------------------------------------- -- checkStability @@ -894,9 +863,6 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' module. So we need to know that we will definitely not be recompiling any of these modules, and we can use the object code. - NB. stability is of no importance to BatchCompile at all, only Interactive. - (ToDo: what about JustTypecheck?) - The stability check is as follows. Both stableObject and stableBCO are used during the upsweep phase later. @@ -915,7 +881,7 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' These properties embody the following ideas: - - if a module is stable: + - if a module is stable, then: - if it has been compiled in a previous pass (present in HPT) then it does not need to be compiled or re-linked. - if it has not been compiled in a previous pass, @@ -1126,95 +1092,133 @@ upsweep_mod :: HscEnv -> IO (Maybe HomeModInfo) -- Nothing => Failed upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods - = do - let - this_mod_name = ms_mod_name summary + = let + this_mod_name = ms_mod_name summary this_mod = ms_mod summary mb_obj_date = ms_obj_date summary obj_fn = ml_obj_file (ms_location summary) hs_date = ms_hs_date summary + is_stable_obj = this_mod_name `elem` stable_obj + is_stable_bco = this_mod_name `elem` stable_bco + + old_hmi = lookupUFM old_hpt this_mod_name + + -- We're using the dflags for this module now, obtained by + -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. + dflags = ms_hspp_opts summary + prevailing_target = hscTarget (hsc_dflags hsc_env) + local_target = hscTarget dflags + + -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that + -- we don't do anything dodgy: these should only work to change + -- from -fvia-C to -fasm and vice-versa, otherwise we could + -- end up trying to link object code to byte code. + target = if prevailing_target /= local_target + && (not (isObjectTarget prevailing_target) + || not (isObjectTarget local_target)) + then prevailing_target + else local_target + + -- store the corrected hscTarget into the summary + summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } + + -- The old interface is ok if + -- a) we're compiling a source file, and the old HPT + -- entry is for a source file + -- b) we're compiling a hs-boot file + -- Case (b) allows an hs-boot file to get the interface of its + -- real source file on the second iteration of the compilation + -- manager, but that does no harm. Otherwise the hs-boot file + -- will always be recompiled + + mb_old_iface + = case old_hmi of + Nothing -> Nothing + Just hm_info | isBootSummary summary -> Just iface + | not (mi_boot iface) -> Just iface + | otherwise -> Nothing + where + iface = hm_iface hm_info + compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo) compile_it = upsweep_compile hsc_env old_hpt this_mod_name - summary mod_index nmods - - case ghcMode (hsc_dflags hsc_env) of - BatchCompile -> - case () of - -- Batch-compilating is easy: just check whether we have - -- an up-to-date object file. If we do, then the compiler - -- needs to do a recompilation check. - _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do - linkable <- - findObjectLinkable this_mod obj_fn obj_date - compile_it (Just linkable) - - | otherwise -> - compile_it Nothing - - interactive -> - case () of - _ | is_stable_obj, isJust old_hmi -> - return old_hmi + summary' mod_index nmods mb_old_iface + + compile_it_discard_iface + = upsweep_compile hsc_env old_hpt this_mod_name + summary' mod_index nmods Nothing + + in + case target of + + _any + -- Regardless of whether we're generating object code or + -- byte code, we can always use an existing object file + -- if it is *stable* (see checkStability). + | is_stable_obj, isJust old_hmi -> + return old_hmi -- object is stable, and we have an entry in the -- old HPT: nothing to do - | is_stable_obj, isNothing old_hmi -> do - linkable <- - findObjectLinkable this_mod obj_fn + | is_stable_obj, isNothing old_hmi -> do + linkable <- findObjectLinkable this_mod obj_fn (expectJust "upseep1" mb_obj_date) - compile_it (Just linkable) + compile_it (Just linkable) -- object is stable, but we need to load the interface -- off disk to make a HMI. - | is_stable_bco -> - ASSERT(isJust old_hmi) -- must be in the old_hpt - return old_hmi + HscInterpreted + | is_stable_bco -> + ASSERT(isJust old_hmi) -- must be in the old_hpt + return old_hmi -- BCO is stable: nothing to do - | Just hmi <- old_hmi, - Just l <- hm_linkable hmi, not (isObjectLinkable l), - linkableTime l >= ms_hs_date summary -> - compile_it (Just l) + | Just hmi <- old_hmi, + Just l <- hm_linkable hmi, not (isObjectLinkable l), + linkableTime l >= ms_hs_date summary -> + compile_it (Just l) -- we have an old BCO that is up to date with respect -- to the source: do a recompilation check as normal. - | otherwise -> - compile_it Nothing + | otherwise -> + compile_it Nothing -- no existing code at all: we must recompile. - where - is_stable_obj = this_mod_name `elem` stable_obj - is_stable_bco = this_mod_name `elem` stable_bco - old_hmi = lookupUFM old_hpt this_mod_name + -- When generating object code, if there's an up-to-date + -- object file on the disk, then we can use it. + -- However, if the object file is new (compared to any + -- linkable we had from a previous compilation), then we + -- must discard any in-memory interface, because this + -- means the user has compiled the source file + -- separately and generated a new interface, that we must + -- read from the disk. + -- + obj | isObjectTarget obj, + Just obj_date <- mb_obj_date, obj_date >= hs_date -> do + case old_hmi of + Just hmi + | Just l <- hm_linkable hmi, + isObjectLinkable l && linkableTime l == obj_date + -> compile_it (Just l) + _otherwise -> do + linkable <- findObjectLinkable this_mod obj_fn obj_date + compile_it_discard_iface (Just linkable) + + _otherwise -> + compile_it Nothing + -- Run hsc to compile a module upsweep_compile hsc_env old_hpt this_mod summary mod_index nmods - mb_old_linkable = do - let - -- The old interface is ok if it's in the old HPT - -- a) we're compiling a source file, and the old HPT - -- entry is for a source file - -- b) we're compiling a hs-boot file - -- Case (b) allows an hs-boot file to get the interface of its - -- real source file on the second iteration of the compilation - -- manager, but that does no harm. Otherwise the hs-boot file - -- will always be recompiled - - mb_old_iface - = case lookupUFM old_hpt this_mod of - Nothing -> Nothing - Just hm_info | isBootSummary summary -> Just iface - | not (mi_boot iface) -> Just iface - | otherwise -> Nothing - where - iface = hm_iface hm_info - - compresult <- compile hsc_env summary mb_old_linkable mb_old_iface + mb_old_iface + mb_old_linkable + = do + compresult <- compile hsc_env summary mb_old_linkable mb_old_iface mod_index nmods - case compresult of + case compresult of -- Compilation failed. Compile may still have updated the PCS, tho. CompErrs -> return Nothing @@ -1767,7 +1771,7 @@ data ModuleInfo = ModuleInfo { 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 } @@ -1808,7 +1812,7 @@ getPackageModuleInfo hsc_env mdl = do 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) @@ -1826,7 +1830,7 @@ getHomeModuleInfo hsc_env mdl = 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 })) @@ -1862,7 +1866,7 @@ modInfoLookupName s minf name = withSession s $ \hsc_env -> do (hsc_HPT hsc_env) (eps_PTE eps) name #ifdef GHCI -modInfoBkptSites = minf_dbg_sites +modInfoModBreaks = minf_modBreaks #endif isDictonaryId :: Id -> Bool @@ -1930,7 +1934,7 @@ findModule' hsc_env mod_name maybe_pkg = case lookupUFM hpt mod_name of Just mod_info -> return (mi_module (hm_iface mod_info)) _not_a_home_module -> do - res <- findImportedModule hsc_env mod_name Nothing + res <- findImportedModule hsc_env mod_name maybe_pkg case res of Found _ m | modulePackageId m /= this_pkg -> return m | otherwise -> throwDyn (CmdLineError (showSDoc $ @@ -1961,7 +1965,6 @@ setContext sess@(Session ref) toplev_mods export_mods = do 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 @@ -2132,14 +2135,24 @@ data RunResult = 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 --- | Run a statement in the current interactive context. Statemenet +data ResumeHandle = ResumeHandle (MVar ()) (MVar Status) [Name] + +-- | 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 @@ -2150,37 +2163,66 @@ runStmt (Session ref) expr 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 @@ -2207,8 +2249,63 @@ sandboxIO thing = do foreign import "rts_evalStableIO" {- safe -} rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt -- more informative than the C type! + +XXX the type of rts_evalStableIO no longer matches the above + -} +-- ----------------------------------------------------------------------------- +-- 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 @@ -2225,72 +2322,8 @@ isModuleInterpreted s mod_summary = withSession s $ \hsc_env -> where obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) -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 (mode == Interactive) $ do - linkEnv <- readIORef v_bkptLinkEnv - initDynLinker dflags - extendLinkEnv linkEnv - -type SiteInfo = (String, String, SiteNumber) -jumpFunction, jumpAutoFunction :: Session -> BkptHandler Module -> Int -> [Opaque] - -> SiteInfo -> String -> b -> b -jumpCondFunction :: Session -> BkptHandler Module -> Int -> [Opaque] - -> SiteInfo -> String -> Bool -> b -> b -jumpFunctionM :: Session -> BkptHandler a -> Int -> [Opaque] -> BkptLocation a - -> String -> b -> IO b - -jumpCondFunction _ _ _ _ _ _ False b = b -jumpCondFunction session handler ptr hValues siteInfo locmsg True b - = jumpFunction session handler ptr hValues siteInfo locmsg b - -jumpFunction session handler ptr hValues siteInfo locmsg b - | site <- mkSite siteInfo - = unsafePerformIO $ jumpFunctionM session handler ptr hValues site locmsg b - -jumpFunctionM session handler (I# idsPtr) wrapped_hValues site locmsg b = - do - ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr))) - ASSERT (length ids == length wrapped_hValues) return () - let hValues = [unsafeCoerce# hv | O hv <- wrapped_hValues] - handleBreakpoint handler session (zip ids hValues) site locmsg b - -jumpAutoFunction session handler ptr hValues siteInfo locmsg b - | site <- mkSite siteInfo - = unsafePerformIO $ do - break <- isAutoBkptEnabled handler session site - if break - then jumpFunctionM session handler ptr hValues site locmsg b - else return b - -jumpStepByStepFunction session handler ptr hValues siteInfo locmsg b - | site <- mkSite siteInfo - = unsafePerformIO $ do - jumpFunctionM session handler ptr hValues site locmsg b - -mkSite :: SiteInfo -> BkptLocation Module -mkSite (pkgName, modName, sitenum) = - (mkModule (stringToPackageId pkgName) (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) obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term) obtainTerm sess force id = withSession sess $ \hsc_env -> do