X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=7e5071b3f77051121369491f900593e7ede67868;hb=1e70478c73505fc3cfd414169cc85654411c8075;hp=a04c06c3799877cf2f8a00342f5f982fb1b69b56;hpb=38e7ac3ffa32d75c1922e7247a910e06d9957116;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index a04c06c..7e5071b 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -87,6 +87,7 @@ module GHC ( obtainTerm, obtainTerm1, ModBreaks(..), BreakIndex, BreakInfo(breakInfo_number, breakInfo_module), + BreakArray, setBreakOn, setBreakOff, getBreak, modInfoModBreaks, #endif @@ -163,6 +164,14 @@ module GHC ( -- ** Source locations SrcLoc, pprDefnLoc, + mkSrcLoc, isGoodSrcLoc, + srcLocFile, srcLocLine, srcLocCol, + SrcSpan, + mkSrcSpan, srcLocSpan, + srcSpanStart, srcSpanEnd, + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, -- * Exceptions GhcException(..), showGhcException, @@ -185,19 +194,18 @@ module GHC ( import RtClosureInspect ( cvObtainTerm, Term ) import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo, tcRnLookupName, getModuleExports ) -import VarEnv ( emptyTidyEnv ) import GHC.Exts ( unsafeCoerce#, Ptr ) import Foreign.StablePtr( deRefStablePtr, StablePtr, newStablePtr, freeStablePtr ) import Foreign ( poke ) import qualified Linker +import Linker ( HValue ) import Data.Dynamic ( Dynamic ) -import Linker ( HValue, getHValue, extendLinkEnv ) import ByteCodeInstr -import DebuggerTys import IdInfo import HscMain ( hscParseIdentifier, hscTcExpr, hscKcType, hscStmt ) +import BreakArray #endif import Packages @@ -205,8 +213,11 @@ import NameSet import RdrName import HsSyn import Type hiding (typeKind) +import TcType hiding (typeKind) import Id import Var hiding (setIdType) +import VarEnv +import VarSet import TysPrim ( alphaTyVars ) import TyCon import Class @@ -241,11 +252,13 @@ import Util import StringBuffer ( StringBuffer, hGetStringBuffer ) import Outputable import BasicTypes -import TcType ( tcSplitSigmaTy, isDictTy ) import Maybes ( expectJust, mapCatMaybes ) import HaddockParse import HaddockLex ( tokenise ) +import Unique +import System.IO.Unsafe +import Data.Array import Control.Concurrent import System.Directory ( getModificationTime, doesFileExist ) import Data.Maybe @@ -321,12 +334,6 @@ defaultCleanupHandler dflags inner = inner -#if defined(GHCI) -GLOBAL_VAR(v_bkptLinkEnv, [], [(Name, HValue)]) - -- stores the current breakpoint handler to help setContext to - -- restore it after a context change -#endif - -- | Starts a new session. A session consists of a set of loaded -- modules, a set of options (DynFlags), and an interactive context. newSession :: Maybe FilePath -> IO Session @@ -494,7 +501,6 @@ depanal (Session ref) excluded_mods allow_dup_roots = do hsc_env <- readIORef ref let dflags = hsc_dflags hsc_env - gmode = ghcMode (hsc_dflags hsc_env) targets = hsc_targets hsc_env old_graph = hsc_mod_graph hsc_env @@ -551,7 +557,6 @@ load2 s@(Session ref) how_much mod_graph = do let hpt1 = hsc_HPT hsc_env let dflags = hsc_dflags hsc_env - let ghci_mode = ghcMode dflags -- this never changes -- The "bad" boot modules are the ones for which we have -- B.hs-boot in the module graph, but no B.hs @@ -2031,8 +2036,15 @@ getNamesInScope s = withSession s $ \hsc_env -> do getRdrNamesInScope :: Session -> IO [RdrName] getRdrNamesInScope s = withSession s $ \hsc_env -> do - let env = ic_rn_gbl_env (hsc_IC hsc_env) - return (concat (map greToRdrNames (globalRdrEnvElts env))) + let + ic = hsc_IC hsc_env + gbl_rdrenv = ic_rn_gbl_env ic + ids = typeEnvIds (ic_type_env ic) + gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv)) + lcl_names = map (mkRdrUnqual.nameOccName.idName) ids + -- + return (gbl_names ++ lcl_names) + -- ToDo: move to RdrName greToRdrNames :: GlobalRdrElt -> [RdrName] @@ -2138,10 +2150,27 @@ data RunResult | 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] + = Break HValue BreakInfo ThreadId + -- ^ the computation hit a breakpoint + | Complete (Either Exception [HValue]) + -- ^ the computation completed with either an exception or a value + +-- | This is a token given back to the client when runStmt stops at a +-- breakpoint. It allows the original computation to be resumed, restoring +-- the old interactive context. +data ResumeHandle + = ResumeHandle + (MVar ()) -- breakMVar + (MVar Status) -- statusMVar + [Name] -- [Name] to bind on completion + InteractiveContext -- IC on completion + InteractiveContext -- IC to restore on resumption + [Name] -- [Name] to remove from the link env + +-- We need to track two InteractiveContexts: +-- - the IC before runStmt, which is restored on each resume +-- - the IC binding the results of the original statement, which +-- will be the IC when runStmt returns with RunOk. -- | Run a statement in the current interactive context. Statement -- may bind multple values. @@ -2162,37 +2191,45 @@ runStmt (Session ref) expr case maybe_stuff of Nothing -> return RunFailed - Just (new_hsc_env, names, hval) -> do - writeIORef ref new_hsc_env + Just (new_IC, names, hval) -> do - 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 + withBreakAction breakMVar statusMVar $ do 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 new_IC names (hsc_IC hsc_env) + breakMVar statusMVar status -handleRunStatus ref names status = +handleRunStatus ref final_ic final_names resume_ic breakMVar statusMVar 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) + (Break apStack info tid) -> do + hsc_env <- readIORef ref + mod_info <- getHomeModuleInfo hsc_env (moduleName (breakInfo_module info)) + let breaks = minf_modBreaks (expectJust "handlRunStatus" mod_info) + let index = breakInfo_number info + occs = modBreaks_vars breaks ! index + span = modBreaks_locs breaks ! index + (new_hsc_env, names) <- extendEnvironment hsc_env apStack span + (breakInfo_vars info) + (breakInfo_resty info) occs + writeIORef ref new_hsc_env + let res = ResumeHandle breakMVar statusMVar final_names + final_ic resume_ic names + return (RunBreak tid names info res) (Complete either_hvals) -> case either_hvals of Left e -> return (RunException e) Right hvals -> do - extendLinkEnv (zip names hvals) - return (RunOk names) - + hsc_env <- readIORef ref + writeIORef ref hsc_env{hsc_IC=final_ic} + Linker.extendLinkEnv (zip final_names hvals) + return (RunOk final_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 ())) @@ -2208,21 +2245,43 @@ sandboxIO statusMVar thing = do putMVar interruptTargetThread (child:ts) 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 +withBreakAction breakMVar statusMVar io + = bracket setBreakAction resetBreakAction (\_ -> io) + where + setBreakAction = do + stablePtr <- newStablePtr onBreak + poke breakPointIOAction stablePtr + return stablePtr + + onBreak info apStack = do + tid <- myThreadId + putMVar statusMVar (Break apStack info tid) + takeMVar breakMVar + + resetBreakAction stablePtr = do + poke breakPointIOAction noBreakStablePtr + freeStablePtr stablePtr + +noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction +noBreakAction info apStack = putStrLn "*** Ignoring breakpoint" 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 +resume (Session ref) res@(ResumeHandle breakMVar statusMVar + final_names final_ic resume_ic names) + = do + -- restore the original interactive context. This is not entirely + -- satisfactory: any new bindings made since the breakpoint stopped + -- will be dropped from the interactive context, but not from the + -- linker's environment. + hsc_env <- readIORef ref + writeIORef ref hsc_env{ hsc_IC = resume_ic } + Linker.deleteFromLinkEnv names + + withBreakAction breakMVar statusMVar $ do + putMVar breakMVar () -- this awakens the stopped thread... + status <- takeMVar statusMVar -- and wait for the result + handleRunStatus ref final_ic final_names resume_ic + breakMVar statusMVar status {- -- This version of sandboxIO runs the expression in a completely new @@ -2258,53 +2317,88 @@ 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 +foreign import ccall unsafe "rts_getApStackVal" + getApStackVal :: StablePtr a -> Int -> IO (StablePtr b) + +getIdValFromApStack :: a -> Int -> IO HValue +getIdValFromApStack apStack stackDepth = do + apSptr <- newStablePtr apStack + resultSptr <- getApStackVal apSptr (stackDepth - 1) + result <- deRefStablePtr resultSptr + freeStablePtr apSptr + freeStablePtr resultSptr + return (unsafeCoerce# result) + +extendEnvironment + :: HscEnv + -> a -- the AP_STACK object built by the interpreter + -> SrcSpan + -> [(Id, Int)] -- free variables and offsets into the AP_STACK + -> Type + -> [OccName] -- names for the variables (from the source code) + -> IO (HscEnv, [Name]) +extendEnvironment hsc_env apStack span idsOffsets result_ty occs = do + + -- filter out any unboxed ids; we can't bind these at the prompt + let pointers = filter (\(id,_) -> isPointer id) idsOffsets + isPointer id | PtrRep <- idPrimRep id = True + | otherwise = False + + let (ids, offsets) = unzip pointers + hValues <- mapM (getIdValFromApStack apStack) offsets + new_ids <- zipWithM mkNewId occs ids 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 + -- make an Id for _result. We use the Unique of the FastString "_result"; + -- we don't care about uniqueness here, because there will only be one + -- _result in scope at any time. + let result_fs = FSLIT("_result") + result_name = mkInternalName (getUnique result_fs) + (mkVarOccFS result_fs) (srcSpanStart span) + result_id = Id.mkLocalId result_name result_ty + + -- for each Id we're about to bind in the local envt: + -- - skolemise the type variables in its type, so they can't + -- be randomly unified with other types. These type variables + -- can only be resolved by type reconstruction in RtClosureInspect + -- - tidy the type variables + -- - globalise the Id (Ids are supposed to be Global, apparently). + -- + let all_ids | isPointer result_id = result_id : ids + | otherwise = ids + (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids + (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys + new_tyvars = unionVarSets tyvarss + new_ids = zipWith setIdType all_ids tidy_tys + global_ids = map (globaliseId VanillaGlobal) new_ids + + let ictxt = extendInteractiveContext (hsc_IC hsc_env) + global_ids new_tyvars + + Linker.extendLinkEnv (zip names hValues) + Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] + return (hsc_env{hsc_IC = ictxt}, result_name:names) + where + mkNewId :: OccName -> Id -> IO Id + mkNewId occ id = do + let uniq = idUnique id + loc = nameSrcLoc (idName id) + name = mkInternalName uniq occ loc + ty = tidyTopType (idType id) + new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id) + return new_id + +skolemiseTy :: Type -> (Type, TyVarSet) +skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars) + where env = mkVarEnv (zip tyvars new_tyvar_tys) + subst = mkTvSubst emptyInScopeSet env + tyvars = varSetElems (tyVarsOfType ty) + new_tyvars = map skolemiseTyVar tyvars + new_tyvar_tys = map mkTyVarTy new_tyvars + +skolemiseTyVar :: TyVar -> TyVar +skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) + (SkolemTv RuntimeUnkSkol) ----------------------------------------------------------------------------- -- show a module and it's source/object filenames @@ -2327,7 +2421,7 @@ obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term) obtainTerm sess force id = withSession sess $ \hsc_env -> do - mb_v <- getHValue (varName id) + mb_v <- Linker.getHValue (varName id) case mb_v of Just v -> fmap Just$ cvObtainTerm hsc_env force (Just$ idType id) v Nothing -> return Nothing