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 StringBuffer ( StringBuffer, hGetStringBuffer )
import Outputable
import BasicTypes
-import TcType ( tcSplitSigmaTy, isDictTy )
import Maybes ( expectJust, mapCatMaybes )
import HaddockParse
import HaddockLex ( tokenise )
-import PrelNames
import Unique
+import System.IO.Unsafe
import Data.Array
import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist )
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]
-- breakpoint this is visible in the Byte Code
-- Interpreter, thus it is a global variable,
-- implemented with stable pointers
- stablePtr <- setBreakAction breakMVar statusMVar
+ 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 new_IC names (hsc_IC hsc_env)
breakMVar statusMVar status
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
+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
writeIORef ref hsc_env{ hsc_IC = resume_ic }
Linker.deleteFromLinkEnv names
- stablePtr <- setBreakAction breakMVar statusMVar
+ withBreakAction breakMVar statusMVar $ do
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
-- 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)
+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
-> [OccName] -- names for the variables (from the source code)
-> IO (HscEnv, [Name])
extendEnvironment hsc_env apStack span idsOffsets result_ty occs = do
- idsVals <- mapM (getIdValFromApStack apStack) idsOffsets
- let (ids, hValues) = unzip idsVals
+
+ -- 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
(mkVarOccFS result_fs) (srcSpanStart span)
result_id = Id.mkLocalId result_name result_ty
- let all_ids = result_id : ids
+ -- 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 id_tys
-
- let ictxt = hsc_IC hsc_env
- type_env = ic_type_env ictxt
- bound_names = map idName new_ids
- -- Remove any shadowed bindings from the type_env;
- -- they are inaccessible but might, I suppose, cause
- -- a space leak if we leave them there
- old_bound_names = map idName (typeEnvIds (ic_type_env ictxt)) ;
- shadowed = [ n | name <- bound_names,
- n <- old_bound_names,
- nameOccName name == nameOccName n ] ;
- filtered_type_env = delListFromNameEnv type_env shadowed
- new_type_env = extendTypeEnvWithIds filtered_type_env new_ids
- old_tyvars = ic_tyvars ictxt
- new_ic = ictxt { ic_type_env = new_type_env,
- ic_tyvars = old_tyvars `unionVarSet` new_tyvars }
+ 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 = new_ic}, result_name:names)
+ return (hsc_env{hsc_IC = ictxt}, result_name:names)
where
mkNewId :: OccName -> Id -> IO Id
mkNewId occ id = do
skolemiseTyVar :: TyVar -> TyVar
skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
- (SkolemTv UnkSkol)
+ (SkolemTv RuntimeUnkSkol)
-----------------------------------------------------------------------------
-- show a module and it's source/object filenames
projects / ghc-hetmet.git / blobdiff