Changing internal data structures used by Hpc

[ghc-hetmet.git] / compiler / main / GHC.hs

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index ef19889..7e5071b 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -194,7 +194,6 @@ 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 )
@@ -253,13 +252,12 @@ import Util
 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 )
@@ -2038,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]
@@ -2192,11 +2197,10 @@ runStmt (Session ref) expr
               -- 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
 
@@ -2241,14 +2245,25 @@ sandboxIO statusMVar thing = do
   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 
@@ -2262,10 +2277,9 @@ 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
 
@@ -2303,17 +2317,17 @@ 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)
+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
@@ -2324,8 +2338,14 @@ extendEnvironment
         -> [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
 
@@ -2344,7 +2364,8 @@ extendEnvironment hsc_env apStack span idsOffsets result_ty occs = do
    --    - tidy the type variables
    --    - globalise the Id (Ids are supposed to be Global, apparently).
    --
-   let all_ids = result_id : ids
+   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