X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=d976152ce86932cfe43df7dd4381098874fbbabe;hb=661bda52ac2708aee8b9c8558fd7cda46a0fb02b;hp=0b93cd8bbe3aa3b2fdb48796584cf38e170b3115;hpb=6d075f13b503ad7b1255911e98f4837a08607ed7;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 0b93cd8..d976152 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -164,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, @@ -196,7 +204,6 @@ import Linker ( HValue ) import Data.Dynamic ( Dynamic ) import ByteCodeInstr -import DebuggerTys import IdInfo import HscMain ( hscParseIdentifier, hscTcExpr, hscKcType, hscStmt ) import BreakArray @@ -207,8 +214,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 @@ -247,7 +257,10 @@ import TcType ( tcSplitSigmaTy, isDictTy ) import Maybes ( expectJust, mapCatMaybes ) import HaddockParse import HaddockLex ( tokenise ) +import PrelNames +import Unique +import Data.Array import Control.Concurrent import System.Directory ( getModificationTime, doesFileExist ) import Data.Maybe @@ -2132,7 +2145,7 @@ data RunResult | RunBreak ThreadId [Name] BreakInfo ResumeHandle data Status - = Break HValue BreakInfo ThreadId (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 @@ -2145,9 +2158,15 @@ data 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. runStmt :: Session -> String -> IO RunResult @@ -2167,38 +2186,43 @@ 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 -- 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 breakMVar statusMVar names + stablePtr <- setBreakAction breakMVar statusMVar 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 (hsc_IC new_hsc_env) names status + handleRunStatus ref new_IC names (hsc_IC hsc_env) + breakMVar statusMVar status -handleRunStatus ref ic 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 breakMVar statusMVar final_names) -> do - hsc_env <- readIORef ref - (new_hsc_env, names) <- extendEnvironment hsc_env apStack - (breakInfo_vars info) - writeIORef ref new_hsc_env - let res = ResumeHandle breakMVar statusMVar final_names - ic names - 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 occs = modBreaks_vars breaks ! breakInfo_number info + (new_hsc_env, names) <- extendEnvironment hsc_env apStack + (breakInfo_vars 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 - Linker.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 ())) @@ -2214,33 +2238,33 @@ sandboxIO statusMVar thing = do putMVar interruptTargetThread (child:ts) takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail) -setBreakAction breakMVar statusMVar final_names = do +setBreakAction breakMVar statusMVar = do stablePtr <- newStablePtr onBreak poke breakPointIOAction stablePtr return stablePtr where onBreak ids apStack = do tid <- myThreadId - putMVar statusMVar (Break apStack ids tid breakMVar statusMVar - final_names) + putMVar statusMVar (Break apStack ids tid) takeMVar breakMVar resume :: Session -> ResumeHandle -> IO RunResult resume (Session ref) res@(ResumeHandle breakMVar statusMVar - final_names ic names) + 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 = ic } + writeIORef ref hsc_env{ hsc_IC = resume_ic } Linker.deleteFromLinkEnv names - stablePtr <- setBreakAction breakMVar statusMVar final_names + stablePtr <- setBreakAction breakMVar statusMVar putMVar breakMVar () -- this awakens the stopped thread... status <- takeMVar statusMVar -- and wait for the result freeStablePtr stablePtr -- be careful not to leak stable pointers! - handleRunStatus ref ic names status + handleRunStatus ref final_ic final_names resume_ic + breakMVar statusMVar status {- -- This version of sandboxIO runs the expression in a completely new @@ -2288,17 +2312,34 @@ getIdValFromApStack apStack (identifier, stackDepth) = do freeStablePtr resultSptr return (identifier, unsafeCoerce# result) -extendEnvironment :: HscEnv -> a -> [(Id, Int)] -> IO (HscEnv, [Name]) -extendEnvironment hsc_env apStack idsOffsets = do +extendEnvironment + :: HscEnv + -> a -- the AP_STACK object built by the interpreter + -> [(Id, Int)] -- free variables and offsets into the AP_STACK + -> [OccName] -- names for the variables (from the source code) + -> IO (HscEnv, [Name]) +extendEnvironment hsc_env apStack idsOffsets occs = do idsVals <- mapM (getIdValFromApStack apStack) idsOffsets let (ids, hValues) = unzip idsVals + new_ids <- zipWithM mkNewId occs ids let names = map idName ids - let global_ids = map globaliseAndTidy ids - typed_ids <- mapM instantiateIdType global_ids + + let tyvars = varSetElems (tyVarsOfTypes (map idType new_ids)) + new_tyvars = map (mkTyVarTy . mk_skol) tyvars + mk_skol tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) + (SkolemTv UnkSkol) + subst = mkTvSubst emptyInScopeSet (mkVarEnv (zip tyvars new_tyvars)) + subst_id id = id `setIdType` substTy subst (idType id) + subst_ids = map subst_id new_ids + + Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknownTyConName + let result_name = mkSystemVarName (mkBuiltinUnique 33) FSLIT("_result") + result_id = Id.mkLocalId result_name (mkTyConApp unknown_tc []) 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 + all_new_ids = result_id : subst_ids + bound_names = map idName all_new_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 @@ -2307,22 +2348,21 @@ extendEnvironment hsc_env apStack idsOffsets = do 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_type_env = extendTypeEnvWithIds filtered_type_env all_new_ids new_ic = ictxt { ic_rn_local_env = new_rn_env, ic_type_env = new_type_env } - Linker.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) + Linker.extendLinkEnv (zip names hValues) + Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] + return (hsc_env{hsc_IC = new_ic}, result_name: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 + 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 ----------------------------------------------------------------------------- -- show a module and it's source/object filenames