exprType,
typeKind,
parseName,
- RunResult(..),
+ RunResult(..), ResumeHandle,
runStmt,
+ resume,
showModule,
isModuleInterpreted,
compileExpr, HValue, dynCompileExpr,
lookupName,
obtainTerm, obtainTerm1,
+ ModBreaks(..), BreakIndex,
+ BreakInfo(breakInfo_number, breakInfo_module),
+ BreakArray, setBreakOn, setBreakOff, getBreak,
modInfoModBreaks,
#endif
-- ** Source locations
SrcLoc, pprDefnLoc,
+ mkSrcLoc, isGoodSrcLoc,
+ srcLocFile, srcLocLine, srcLocCol,
+ SrcSpan,
+ mkSrcSpan, srcLocSpan,
+ srcSpanStart, srcSpanEnd,
+ srcSpanFile,
+ srcSpanStartLine, srcSpanEndLine,
+ srcSpanStartCol, srcSpanEndCol,
-- * Exceptions
GhcException(..), showGhcException,
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#, Ptr )
-import Foreign.StablePtr( deRefStablePtr, castPtrToStablePtr, StablePtr, newStablePtr, freeStablePtr )
+import Foreign.StablePtr( deRefStablePtr, StablePtr, newStablePtr, freeStablePtr )
import Foreign ( poke )
-import Data.Maybe ( fromMaybe)
import qualified Linker
+import Linker ( HValue )
import Data.Dynamic ( Dynamic )
-import Linker ( HValue, getHValue, extendLinkEnv )
-import ByteCodeInstr (BreakInfo)
+import ByteCodeInstr
+import IdInfo
+import HscMain ( hscParseIdentifier, hscTcExpr, hscKcType, hscStmt )
+import BreakArray
#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 TcType hiding (typeKind)
+import Id
+import Var hiding (setIdType)
+import VarEnv
+import VarSet
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 PrelNames
+import Unique
+import Data.Array
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)
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
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
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
= RunOk [Name] -- ^ names bound by this evaluation
| RunFailed -- ^ statement failed compilation
| RunException Exception -- ^ statement raised an exception
- | forall a . RunBreak a ThreadId BreakInfo (IO RunResult)
-
-data Status a
- = Break RunResult -- ^ the computation hit a breakpoint
- | Complete (Either Exception a) -- ^ the computation completed with either an exception or a value
+ | RunBreak ThreadId [Name] BreakInfo ResumeHandle
+
+data Status
+ = 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.
case maybe_stuff of
Nothing -> return RunFailed
- Just (new_hsc_env, names, hval) -> do
-
- -- resume says what to do when we continue execution from a breakpoint
- -- onBreakAction says what to do when we hit a breakpoint
- -- they are mutually recursive, hence the strange use tuple let-binding
- let (resume, onBreakAction)
- = ( do stablePtr <- newStablePtr onBreakAction
- poke breakPointIOAction stablePtr
- putMVar breakMVar ()
- status <- takeMVar statusMVar
- switchOnStatus ref new_hsc_env names status
- , \ids apStack -> do
- tid <- myThreadId
- putMVar statusMVar (Break (RunBreak apStack tid ids resume))
- takeMVar breakMVar
- )
-
- -- 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 <- newStablePtr onBreakAction
- poke breakPointIOAction stablePtr
+ 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
let thing_to_run = unsafeCoerce# hval :: IO [HValue]
status <- sandboxIO statusMVar thing_to_run
freeStablePtr stablePtr -- be careful not to leak stable pointers!
- switchOnStatus ref new_hsc_env names status
- where
- switchOnStatus ref hs_env names status =
- case status of
- -- did we hit a breakpoint or did we complete?
- (Break result) -> return result
- (Complete either_hvals) ->
+ handleRunStatus ref new_IC names (hsc_IC hsc_env)
+ breakMVar statusMVar 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) -> 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
- extendLinkEnv (zip names hvals)
- writeIORef ref hs_env
- 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 (a -> BreakInfo -> IO ()))
+ 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 :: MVar (Status a) -> IO a -> IO (Status a)
+sandboxIO :: MVar Status -> IO [HValue] -> IO Status
sandboxIO statusMVar thing = do
ts <- takeMVar interruptTargetThread
child <- forkIO (do res <- Exception.try thing; putMVar statusMVar (Complete res))
putMVar interruptTargetThread (child:ts)
takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail)
+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)
+ takeMVar breakMVar
+
+resume :: Session -> ResumeHandle -> IO RunResult
+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
+
+ 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 final_ic final_names resume_ic
+ breakMVar statusMVar status
+
{-
-- This version of sandboxIO runs the expression in a completely new
-- RTS main thread. It is disabled for now because ^C exceptions
-}
+-- -----------------------------------------------------------------------------
+-- 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 -- 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 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
+ 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
+ -- 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 all_new_ids
+ new_ic = ictxt { ic_rn_local_env = new_rn_env,
+ ic_type_env = new_type_env }
+ Linker.extendLinkEnv (zip names hValues)
+ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
+ return (hsc_env{hsc_IC = new_ic}, 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
-----------------------------------------------------------------------------
-- show a module and it's source/object filenames
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