compiler/main/InteractiveEval.hs

   1 -- -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow, 2005-2007
   4 --
   5 -- Running statements interactively
   6 --
   7 -- -----------------------------------------------------------------------------
   8
   9 module InteractiveEval (
  10 #ifdef GHCI
  11         RunResult(..), Status(..), Resume(..), History(..),
  12         runStmt, SingleStep(..),
  13         resume,
  14         abandon, abandonAll,
  15         getResumeContext,
  16         getHistorySpan,
  17         back, forward,
  18         setContext, getContext,
  19         nameSetToGlobalRdrEnv,
  20         getNamesInScope,
  21         getRdrNamesInScope,
  22         moduleIsInterpreted,
  23         getInfo,
  24         exprType,
  25         typeKind,
  26         parseName,
  27         showModule,
  28         isModuleInterpreted,
  29         compileExpr, dynCompileExpr,
  30         lookupName,
  31         obtainTerm, obtainTerm1
  32 #endif
  33         ) where
  34
  35 #ifdef GHCI
  36
  37 #include "HsVersions.h"
  38
  39 import HscMain          hiding (compileExpr)
  40 import HscTypes
  41 import TcRnDriver
  42 import Type             hiding (typeKind)
  43 import TcType           hiding (typeKind)
  44 import InstEnv
  45 import Var              hiding (setIdType)
  46 import Id
  47 import IdInfo
  48 import Name             hiding ( varName )
  49 import NameSet
  50 import RdrName
  51 import VarSet
  52 import VarEnv
  53 import ByteCodeInstr
  54 import Linker
  55 import DynFlags
  56 import Unique
  57 import Module
  58 import Panic
  59 import UniqFM
  60 import Maybes
  61 import ErrUtils
  62 import Util
  63 import SrcLoc
  64 import BreakArray
  65 import RtClosureInspect
  66 import Packages
  67 import BasicTypes
  68 import Outputable
  69
  70 import Data.Dynamic
  71 import Control.Monad
  72 import Foreign
  73 import Foreign.C
  74 import GHC.Exts
  75 import Data.Array
  76 import Control.Exception as Exception
  77 import Control.Concurrent
  78 import Data.IORef
  79 import Foreign.StablePtr
  80
  81 -- -----------------------------------------------------------------------------
  82 -- running a statement interactively
  83
  84 data RunResult
  85   = RunOk [Name]                -- ^ names bound by this evaluation
  86   | RunFailed                   -- ^ statement failed compilation
  87   | RunException Exception      -- ^ statement raised an exception
  88   | RunBreak ThreadId [Name] (Maybe BreakInfo)
  89
  90 data Status
  91    = Break Bool HValue BreakInfo ThreadId
  92           -- ^ the computation hit a breakpoint (Bool <=> was an exception)
  93    | Complete (Either Exception [HValue])
  94           -- ^ the computation completed with either an exception or a value
  95
  96 data Resume
  97    = Resume {
  98        resumeStmt      :: String,       -- the original statement
  99        resumeThreadId  :: ThreadId,     -- thread running the computation
 100        resumeBreakMVar :: MVar (),
 101        resumeStatMVar  :: MVar Status,
 102        resumeBindings  :: ([Id], TyVarSet),
 103        resumeFinalIds  :: [Id],         -- [Id] to bind on completion
 104        resumeApStack   :: HValue,       -- The object from which we can get
 105                                         -- value of the free variables.
 106        resumeBreakInfo :: Maybe BreakInfo,
 107                                         -- the breakpoint we stopped at
 108                                         -- (Nothing <=> exception)
 109        resumeSpan      :: SrcSpan,      -- just a cache, otherwise it's a pain
 110                                         -- to fetch the ModDetails & ModBreaks
 111                                         -- to get this.
 112        resumeHistory   :: [History],
 113        resumeHistoryIx :: Int           -- 0 <==> at the top of the history
 114    }
 115
 116 getResumeContext :: Session -> IO [Resume]
 117 getResumeContext s = withSession s (return . ic_resume . hsc_IC)
 118
 119 data SingleStep
 120    = RunToCompletion
 121    | SingleStep
 122    | RunAndLogSteps
 123
 124 isStep RunToCompletion = False
 125 isStep _ = True
 126
 127 data History
 128    = History {
 129         historyApStack   :: HValue,
 130         historyBreakInfo :: BreakInfo
 131    }
 132
 133 getHistorySpan :: Session -> History -> IO SrcSpan
 134 getHistorySpan s hist = withSession s $ \hsc_env -> do
 135    let inf = historyBreakInfo hist
 136        num = breakInfo_number inf
 137    case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
 138        Just hmi -> return (modBreaks_locs (md_modBreaks (hm_details hmi)) ! num)
 139        _ -> panic "getHistorySpan"
 140
 141 -- | Run a statement in the current interactive context.  Statement
 142 -- may bind multple values.
 143 runStmt :: Session -> String -> SingleStep -> IO RunResult
 144 runStmt (Session ref) expr step
 145    = do
 146         hsc_env <- readIORef ref
 147
 148         breakMVar  <- newEmptyMVar  -- wait on this when we hit a breakpoint
 149         statusMVar <- newEmptyMVar  -- wait on this when a computation is running
 150
 151         -- Turn off -fwarn-unused-bindings when running a statement, to hide
 152         -- warnings about the implicit bindings we introduce.
 153         let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
 154             hsc_env' = hsc_env{ hsc_dflags = dflags' }
 155
 156         maybe_stuff <- hscStmt hsc_env' expr
 157
 158         case maybe_stuff of
 159            Nothing -> return RunFailed
 160            Just (ids, hval) -> do
 161
 162               withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
 163
 164               let thing_to_run = unsafeCoerce# hval :: IO [HValue]
 165               status <- sandboxIO statusMVar thing_to_run
 166
 167               let ic = hsc_IC hsc_env
 168                   bindings = (ic_tmp_ids ic, ic_tyvars ic)
 169
 170               case step of
 171                 RunAndLogSteps ->
 172                         traceRunStatus expr ref bindings ids
 173                                        breakMVar statusMVar status emptyHistory
 174                 _other ->
 175                         handleRunStatus expr ref bindings ids
 176                                         breakMVar statusMVar status emptyHistory
 177
 178
 179 emptyHistory = nilBL 50 -- keep a log of length 50
 180
 181 handleRunStatus expr ref bindings final_ids breakMVar statusMVar status
 182                 history =
 183    case status of
 184       -- did we hit a breakpoint or did we complete?
 185       (Break is_exception apStack info tid) -> do
 186         hsc_env <- readIORef ref
 187         let mb_info | is_exception = Nothing
 188                     | otherwise    = Just info
 189         (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
 190                                                           apStack mb_info
 191         let
 192             resume = Resume expr tid breakMVar statusMVar
 193                               bindings final_ids apStack mb_info span
 194                               (toListBL history) 0
 195             hsc_env2 = pushResume hsc_env1 resume
 196         --
 197         writeIORef ref hsc_env2
 198         return (RunBreak tid names mb_info)
 199       (Complete either_hvals) ->
 200         case either_hvals of
 201             Left e -> return (RunException e)
 202             Right hvals -> do
 203                 hsc_env <- readIORef ref
 204                 let final_ic = extendInteractiveContext (hsc_IC hsc_env)
 205                                         final_ids emptyVarSet
 206                         -- the bound Ids never have any free TyVars
 207                     final_names = map idName final_ids
 208                 writeIORef ref hsc_env{hsc_IC=final_ic}
 209                 Linker.extendLinkEnv (zip final_names hvals)
 210                 return (RunOk final_names)
 211
 212
 213 traceRunStatus expr ref bindings final_ids
 214                breakMVar statusMVar status history = do
 215   hsc_env <- readIORef ref
 216   case status of
 217      -- when tracing, if we hit a breakpoint that is not explicitly
 218      -- enabled, then we just log the event in the history and continue.
 219      (Break is_exception apStack info tid) | not is_exception -> do
 220         b <- isBreakEnabled hsc_env info
 221         if b
 222            then handle_normally
 223            else do
 224              let history' = consBL (History apStack info) history
 225                 -- probably better make history strict here, otherwise
 226                 -- our BoundedList will be pointless.
 227              evaluate history'
 228              status <- withBreakAction True (hsc_dflags hsc_env)
 229                                  breakMVar statusMVar $ do
 230                        withInterruptsSentTo
 231                          (do putMVar breakMVar ()  -- awaken the stopped thread
 232                              return tid)
 233                          (takeMVar statusMVar)     -- and wait for the result
 234              traceRunStatus expr ref bindings final_ids
 235                             breakMVar statusMVar status history'
 236      _other ->
 237         handle_normally
 238   where
 239         handle_normally = handleRunStatus expr ref bindings final_ids
 240                                           breakMVar statusMVar status history
 241
 242
 243 isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
 244 isBreakEnabled hsc_env inf =
 245    case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
 246        Just hmi -> do
 247          w <- getBreak (modBreaks_flags (md_modBreaks (hm_details hmi)))
 248                        (breakInfo_number inf)
 249          case w of Just n -> return (n /= 0); _other -> return False
 250        _ ->
 251          return False
 252
 253
 254 foreign import ccall "&rts_stop_next_breakpoint" stepFlag      :: Ptr CInt
 255 foreign import ccall "&rts_stop_on_exception"    exceptionFlag :: Ptr CInt
 256
 257 setStepFlag   = poke stepFlag 1
 258 resetStepFlag = poke stepFlag 0
 259
 260 -- this points to the IO action that is executed when a breakpoint is hit
 261 foreign import ccall "&rts_breakpoint_io_action"
 262    breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
 263
 264 -- When running a computation, we redirect ^C exceptions to the running
 265 -- thread.  ToDo: we might want a way to continue even if the target
 266 -- thread doesn't die when it receives the exception... "this thread
 267 -- is not responding".
 268 sandboxIO :: MVar Status -> IO [HValue] -> IO Status
 269 sandboxIO statusMVar thing =
 270   withInterruptsSentTo
 271         (forkIO (do res <- Exception.try (rethrow thing)
 272                     putMVar statusMVar (Complete res)))
 273         (takeMVar statusMVar)
 274
 275 -- | this just re-throws any exceptions received.  The point of this
 276 -- is that if -fbreak-on-excepsions is on, we only get a chance to break
 277 -- for synchronous exceptions, and this turns an async exception into
 278 -- a sync exception, so for instance a ^C exception will break right here
 279 -- unless it is caught elsewhere.
 280 rethrow :: IO a -> IO a
 281 rethrow io = Exception.catch io Exception.throwIO
 282
 283 withInterruptsSentTo :: IO ThreadId -> IO r -> IO r
 284 withInterruptsSentTo io get_result = do
 285   ts <- takeMVar interruptTargetThread
 286   child <- io
 287   putMVar interruptTargetThread (child:ts)
 288   get_result `finally` modifyMVar_ interruptTargetThread (return.tail)
 289
 290 -- This function sets up the interpreter for catching breakpoints, and
 291 -- resets everything when the computation has stopped running.  This
 292 -- is a not-very-good way to ensure that only the interactive
 293 -- evaluation should generate breakpoints.
 294 withBreakAction step dflags breakMVar statusMVar io
 295  = bracket setBreakAction resetBreakAction (\_ -> io)
 296  where
 297    setBreakAction = do
 298      stablePtr <- newStablePtr onBreak
 299      poke breakPointIOAction stablePtr
 300      when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
 301      when step $ setStepFlag
 302      return stablePtr
 303         -- Breaking on exceptions is not enabled by default, since it
 304         -- might be a bit surprising.  The exception flag is turned off
 305         -- as soon as it is hit, or in resetBreakAction below.
 306
 307    onBreak is_exception info apStack = do
 308      tid <- myThreadId
 309      putMVar statusMVar (Break is_exception apStack info tid)
 310      takeMVar breakMVar
 311
 312    resetBreakAction stablePtr = do
 313      poke breakPointIOAction noBreakStablePtr
 314      poke exceptionFlag 0
 315      resetStepFlag
 316      freeStablePtr stablePtr
 317
 318 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
 319
 320 noBreakAction False info apStack = putStrLn "*** Ignoring breakpoint"
 321 noBreakAction True  info apStack = return () -- exception: just continue
 322
 323 resume :: Session -> SingleStep -> IO RunResult
 324 resume (Session ref) step
 325  = do
 326    hsc_env <- readIORef ref
 327    let ic = hsc_IC hsc_env
 328        resume = ic_resume ic
 329
 330    case resume of
 331      [] -> throwDyn (ProgramError "not stopped at a breakpoint")
 332      (r:rs) -> do
 333         -- unbind the temporary locals by restoring the TypeEnv from
 334         -- before the breakpoint, and drop this Resume from the
 335         -- InteractiveContext.
 336         let (resume_tmp_ids, resume_tyvars) = resumeBindings r
 337             ic' = ic { ic_tmp_ids  = resume_tmp_ids,
 338                        ic_tyvars   = resume_tyvars,
 339                        ic_resume   = rs }
 340         writeIORef ref hsc_env{ hsc_IC = ic' }
 341
 342         -- remove any bindings created since the breakpoint from the
 343         -- linker's environment
 344         let new_names = map idName (filter (`notElem` resume_tmp_ids)
 345                                            (ic_tmp_ids ic))
 346         Linker.deleteFromLinkEnv new_names
 347
 348         when (isStep step) $ setStepFlag
 349         case r of
 350           Resume expr tid breakMVar statusMVar bindings
 351               final_ids apStack info _ _ _ -> do
 352                 withBreakAction (isStep step) (hsc_dflags hsc_env)
 353                                         breakMVar statusMVar $ do
 354                 status <- withInterruptsSentTo
 355                              (do putMVar breakMVar ()
 356                                       -- this awakens the stopped thread...
 357                                  return tid)
 358                              (takeMVar statusMVar)
 359                                       -- and wait for the result
 360                 case step of
 361                   RunAndLogSteps ->
 362                         traceRunStatus expr ref bindings final_ids
 363                                        breakMVar statusMVar status emptyHistory
 364                   _other ->
 365                         handleRunStatus expr ref bindings final_ids
 366                                         breakMVar statusMVar status emptyHistory
 367
 368
 369 back :: Session -> IO ([Name], Int, SrcSpan)
 370 back  = moveHist (+1)
 371
 372 forward :: Session -> IO ([Name], Int, SrcSpan)
 373 forward  = moveHist (subtract 1)
 374
 375 moveHist fn (Session ref) = do
 376   hsc_env <- readIORef ref
 377   case ic_resume (hsc_IC hsc_env) of
 378      [] -> throwDyn (ProgramError "not stopped at a breakpoint")
 379      (r:rs) -> do
 380         let ix = resumeHistoryIx r
 381             history = resumeHistory r
 382             new_ix = fn ix
 383         --
 384         when (new_ix > length history) $
 385            throwDyn (ProgramError "no more logged breakpoints")
 386         when (new_ix < 0) $
 387            throwDyn (ProgramError "already at the beginning of the history")
 388
 389         let
 390           update_ic apStack mb_info = do
 391             (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
 392                                                 apStack mb_info
 393             let ic = hsc_IC hsc_env1
 394                 r' = r { resumeHistoryIx = new_ix }
 395                 ic' = ic { ic_resume = r':rs }
 396
 397             writeIORef ref hsc_env1{ hsc_IC = ic' }
 398
 399             return (names, new_ix, span)
 400
 401         -- careful: we want apStack to be the AP_STACK itself, not a thunk
 402         -- around it, hence the cases are carefully constructed below to
 403         -- make this the case.  ToDo: this is v. fragile, do something better.
 404         if new_ix == 0
 405            then case r of
 406                    Resume { resumeApStack = apStack,
 407                             resumeBreakInfo = mb_info } ->
 408                           update_ic apStack mb_info
 409            else case history !! (new_ix - 1) of
 410                    History apStack info ->
 411                           update_ic apStack (Just info)
 412
 413 -- -----------------------------------------------------------------------------
 414 -- After stopping at a breakpoint, add free variables to the environment
 415
 416 bindLocalsAtBreakpoint
 417         :: HscEnv
 418         -> HValue
 419         -> Maybe BreakInfo
 420         -> IO (HscEnv, [Name], SrcSpan)
 421
 422 -- Nothing case: we stopped when an exception was raised, not at a
 423 -- breakpoint.  We have no location information or local variables to
 424 -- bind, all we can do is bind a local variable to the exception
 425 -- value.
 426 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
 427    let exn_fs    = FSLIT("_exception")
 428        exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
 429        e_fs      = FSLIT("e")
 430        e_name    = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
 431        e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
 432        exn_id    = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
 433                                 vanillaIdInfo
 434        new_tyvars = unitVarSet e_tyvar
 435
 436        ictxt0 = hsc_IC hsc_env
 437        ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
 438
 439        span = mkGeneralSrcSpan FSLIT("<exception thrown>")
 440    --
 441    Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
 442    return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
 443
 444 -- Just case: we stopped at a breakpoint, we have information about the location
 445 -- of the breakpoint and the free variables of the expression.
 446 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
 447
 448    let
 449        mod_name    = moduleName (breakInfo_module info)
 450        mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name)
 451        breaks      = md_modBreaks (expectJust "handlRunStatus" mod_details)
 452        index     = breakInfo_number info
 453        vars      = breakInfo_vars info
 454        result_ty = breakInfo_resty info
 455        occs      = modBreaks_vars breaks ! index
 456        span      = modBreaks_locs breaks ! index
 457
 458    -- filter out any unboxed ids; we can't bind these at the prompt
 459    let pointers = filter (\(id,_) -> isPointer id) vars
 460        isPointer id | PtrRep <- idPrimRep id = True
 461                     | otherwise              = False
 462
 463    let (ids, offsets) = unzip pointers
 464
 465    -- It might be that getIdValFromApStack fails, because the AP_STACK
 466    -- has been accidentally evaluated, or something else has gone wrong.
 467    -- So that we don't fall over in a heap when this happens, just don't
 468    -- bind any free variables instead, and we emit a warning.
 469    mb_hValues <- mapM (getIdValFromApStack apStack) offsets
 470    let filtered_ids = [ id | (id, Just _) <- zip ids mb_hValues ]
 471    when (any isNothing mb_hValues) $
 472       debugTraceMsg (hsc_dflags hsc_env) 1 $
 473           text "Warning: _result has been evaluated, some bindings have been lost"
 474
 475    new_ids <- zipWithM mkNewId occs filtered_ids
 476    let names = map idName new_ids
 477
 478    -- make an Id for _result.  We use the Unique of the FastString "_result";
 479    -- we don't care about uniqueness here, because there will only be one
 480    -- _result in scope at any time.
 481    let result_fs = FSLIT("_result")
 482        result_name = mkInternalName (getUnique result_fs)
 483                           (mkVarOccFS result_fs) span
 484        result_id   = Id.mkGlobalId VanillaGlobal result_name result_ty
 485                                    vanillaIdInfo
 486
 487    -- for each Id we're about to bind in the local envt:
 488    --    - skolemise the type variables in its type, so they can't
 489    --      be randomly unified with other types.  These type variables
 490    --      can only be resolved by type reconstruction in RtClosureInspect
 491    --    - tidy the type variables
 492    --    - globalise the Id (Ids are supposed to be Global, apparently).
 493    --
 494    let all_ids | isPointer result_id = result_id : new_ids
 495                | otherwise           = new_ids
 496        (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
 497        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
 498        new_tyvars = unionVarSets tyvarss
 499        final_ids = zipWith setIdType all_ids tidy_tys
 500
 501    let   ictxt0 = hsc_IC hsc_env
 502          ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
 503
 504    Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
 505    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
 506    return (hsc_env{ hsc_IC = ictxt1 }, result_name:names, span)
 507   where
 508    mkNewId :: OccName -> Id -> IO Id
 509    mkNewId occ id = do
 510      let uniq = idUnique id
 511          loc = nameSrcSpan (idName id)
 512          name = mkInternalName uniq occ loc
 513          ty = idType id
 514          new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
 515      return new_id
 516
 517 skolemiseTy :: Type -> (Type, TyVarSet)
 518 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
 519   where env           = mkVarEnv (zip tyvars new_tyvar_tys)
 520         subst         = mkTvSubst emptyInScopeSet env
 521         tyvars        = varSetElems (tyVarsOfType ty)
 522         new_tyvars    = map skolemiseTyVar tyvars
 523         new_tyvar_tys = map mkTyVarTy new_tyvars
 524
 525 skolemiseTyVar :: TyVar -> TyVar
 526 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
 527                                  (SkolemTv RuntimeUnkSkol)
 528
 529 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
 530 getIdValFromApStack apStack (I# stackDepth) = do
 531    case getApStackVal# apStack (stackDepth +# 1#) of
 532                                 -- The +1 is magic!  I don't know where it comes
 533                                 -- from, but this makes things line up.  --SDM
 534         (# ok, result #) ->
 535             case ok of
 536               0# -> return Nothing -- AP_STACK not found
 537               _  -> return (Just (unsafeCoerce# result))
 538
 539 pushResume :: HscEnv -> Resume -> HscEnv
 540 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
 541   where
 542         ictxt0 = hsc_IC hsc_env
 543         ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
 544
 545 -- -----------------------------------------------------------------------------
 546 -- Abandoning a resume context
 547
 548 abandon :: Session -> IO Bool
 549 abandon (Session ref) = do
 550    hsc_env <- readIORef ref
 551    let ic = hsc_IC hsc_env
 552        resume = ic_resume ic
 553    case resume of
 554       []    -> return False
 555       r:rs  -> do
 556          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
 557          abandon_ r
 558          return True
 559
 560 abandonAll :: Session -> IO Bool
 561 abandonAll (Session ref) = do
 562    hsc_env <- readIORef ref
 563    let ic = hsc_IC hsc_env
 564        resume = ic_resume ic
 565    case resume of
 566       []  -> return False
 567       rs  -> do
 568          writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
 569          mapM_ abandon_ rs
 570          return True
 571
 572 -- when abandoning a computation we have to
 573 --      (a) kill the thread with an async exception, so that the
 574 --          computation itself is stopped, and
 575 --      (b) fill in the MVar.  This step is necessary because any
 576 --          thunks that were under evaluation will now be updated
 577 --          with the partial computation, which still ends in takeMVar,
 578 --          so any attempt to evaluate one of these thunks will block
 579 --          unless we fill in the MVar.
 580 --  See test break010.
 581 abandon_ :: Resume -> IO ()
 582 abandon_ r = do
 583   killThread (resumeThreadId r)
 584   putMVar (resumeBreakMVar r) ()
 585
 586 -- -----------------------------------------------------------------------------
 587 -- Bounded list, optimised for repeated cons
 588
 589 data BoundedList a = BL
 590                         {-# UNPACK #-} !Int  -- length
 591                         {-# UNPACK #-} !Int  -- bound
 592                         [a] -- left
 593                         [a] -- right,  list is (left ++ reverse right)
 594
 595 nilBL :: Int -> BoundedList a
 596 nilBL bound = BL 0 bound [] []
 597
 598 consBL a (BL len bound left right)
 599   | len < bound = BL (len+1) bound (a:left) right
 600   | null right  = BL len     bound [a]      $! tail (reverse left)
 601   | otherwise   = BL len     bound (a:left) $! tail right
 602
 603 toListBL (BL _ _ left right) = left ++ reverse right
 604
 605 -- lenBL (BL len _ _ _) = len
 606
 607 -- -----------------------------------------------------------------------------
 608 -- | Set the interactive evaluation context.
 609 --
 610 -- Setting the context doesn't throw away any bindings; the bindings
 611 -- we've built up in the InteractiveContext simply move to the new
 612 -- module.  They always shadow anything in scope in the current context.
 613 setContext :: Session
 614            -> [Module]  -- entire top level scope of these modules
 615            -> [Module]  -- exports only of these modules
 616            -> IO ()
 617 setContext sess@(Session ref) toplev_mods export_mods = do
 618   hsc_env <- readIORef ref
 619   let old_ic  = hsc_IC     hsc_env
 620       hpt     = hsc_HPT    hsc_env
 621   --
 622   export_env  <- mkExportEnv hsc_env export_mods
 623   toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
 624   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
 625   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
 626                                             ic_exports      = export_mods,
 627                                             ic_rn_gbl_env   = all_env }}
 628
 629 -- Make a GlobalRdrEnv based on the exports of the modules only.
 630 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 631 mkExportEnv hsc_env mods = do
 632   stuff <- mapM (getModuleExports hsc_env) mods
 633   let
 634         (_msgs, mb_name_sets) = unzip stuff
 635         gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
 636                | (Just avails, mod) <- zip mb_name_sets mods ]
 637   --
 638   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
 639
 640 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
 641 nameSetToGlobalRdrEnv names mod =
 642   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
 643                  | name <- nameSetToList names ]
 644
 645 vanillaProv :: ModuleName -> Provenance
 646 -- We're building a GlobalRdrEnv as if the user imported
 647 -- all the specified modules into the global interactive module
 648 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 649   where
 650     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
 651                          is_qual = False,
 652                          is_dloc = srcLocSpan interactiveSrcLoc }
 653
 654 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 655 mkTopLevEnv hpt modl
 656   = case lookupUFM hpt (moduleName modl) of
 657       Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
 658                                                 showSDoc (ppr modl)))
 659       Just details ->
 660          case mi_globals (hm_iface details) of
 661                 Nothing  ->
 662                    throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
 663                                                 ++ showSDoc (ppr modl)))
 664                 Just env -> return env
 665
 666 -- | Get the interactive evaluation context, consisting of a pair of the
 667 -- set of modules from which we take the full top-level scope, and the set
 668 -- of modules from which we take just the exports respectively.
 669 getContext :: Session -> IO ([Module],[Module])
 670 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
 671                                 return (ic_toplev_scope ic, ic_exports ic))
 672
 673 -- | Returns 'True' if the specified module is interpreted, and hence has
 674 -- its full top-level scope available.
 675 moduleIsInterpreted :: Session -> Module -> IO Bool
 676 moduleIsInterpreted s modl = withSession s $ \h ->
 677  if modulePackageId modl /= thisPackage (hsc_dflags h)
 678         then return False
 679         else case lookupUFM (hsc_HPT h) (moduleName modl) of
 680                 Just details       -> return (isJust (mi_globals (hm_iface details)))
 681                 _not_a_home_module -> return False
 682
 683 -- | Looks up an identifier in the current interactive context (for :info)
 684 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
 685 getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
 686
 687 -- | Returns all names in scope in the current interactive context
 688 getNamesInScope :: Session -> IO [Name]
 689 getNamesInScope s = withSession s $ \hsc_env -> do
 690   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 691
 692 getRdrNamesInScope :: Session -> IO [RdrName]
 693 getRdrNamesInScope  s = withSession s $ \hsc_env -> do
 694   let
 695       ic = hsc_IC hsc_env
 696       gbl_rdrenv = ic_rn_gbl_env ic
 697       ids = ic_tmp_ids ic
 698       gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
 699       lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
 700   --
 701   return (gbl_names ++ lcl_names)
 702
 703
 704 -- ToDo: move to RdrName
 705 greToRdrNames :: GlobalRdrElt -> [RdrName]
 706 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 707   = case prov of
 708      LocalDef -> [unqual]
 709      Imported specs -> concat (map do_spec (map is_decl specs))
 710   where
 711     occ = nameOccName name
 712     unqual = Unqual occ
 713     do_spec decl_spec
 714         | is_qual decl_spec = [qual]
 715         | otherwise         = [unqual,qual]
 716         where qual = Qual (is_as decl_spec) occ
 717
 718 -- | Parses a string as an identifier, and returns the list of 'Name's that
 719 -- the identifier can refer to in the current interactive context.
 720 parseName :: Session -> String -> IO [Name]
 721 parseName s str = withSession s $ \hsc_env -> do
 722    maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
 723    case maybe_rdr_name of
 724         Nothing -> return []
 725         Just (L _ rdr_name) -> do
 726             mb_names <- tcRnLookupRdrName hsc_env rdr_name
 727             case mb_names of
 728                 Nothing -> return []
 729                 Just ns -> return ns
 730                 -- ToDo: should return error messages
 731
 732 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 733 -- entity known to GHC, including 'Name's defined using 'runStmt'.
 734 lookupName :: Session -> Name -> IO (Maybe TyThing)
 735 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
 736
 737 -- -----------------------------------------------------------------------------
 738 -- Getting the type of an expression
 739
 740 -- | Get the type of an expression
 741 exprType :: Session -> String -> IO (Maybe Type)
 742 exprType s expr = withSession s $ \hsc_env -> do
 743    maybe_stuff <- hscTcExpr hsc_env expr
 744    case maybe_stuff of
 745         Nothing -> return Nothing
 746         Just ty -> return (Just tidy_ty)
 747              where
 748                 tidy_ty = tidyType emptyTidyEnv ty
 749
 750 -- -----------------------------------------------------------------------------
 751 -- Getting the kind of a type
 752
 753 -- | Get the kind of a  type
 754 typeKind  :: Session -> String -> IO (Maybe Kind)
 755 typeKind s str = withSession s $ \hsc_env -> do
 756    maybe_stuff <- hscKcType hsc_env str
 757    case maybe_stuff of
 758         Nothing -> return Nothing
 759         Just kind -> return (Just kind)
 760
 761 -----------------------------------------------------------------------------
 762 -- cmCompileExpr: compile an expression and deliver an HValue
 763
 764 compileExpr :: Session -> String -> IO (Maybe HValue)
 765 compileExpr s expr = withSession s $ \hsc_env -> do
 766   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
 767   case maybe_stuff of
 768         Nothing -> return Nothing
 769         Just (ids, hval) -> do
 770                         -- Run it!
 771                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
 772
 773                 case (ids,hvals) of
 774                   ([n],[hv]) -> return (Just hv)
 775                   _          -> panic "compileExpr"
 776
 777 -- -----------------------------------------------------------------------------
 778 -- Compile an expression into a dynamic
 779
 780 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
 781 dynCompileExpr ses expr = do
 782     (full,exports) <- getContext ses
 783     setContext ses full $
 784         (mkModule
 785             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
 786         ):exports
 787     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
 788     res <- withSession ses (flip hscStmt stmt)
 789     setContext ses full exports
 790     case res of
 791         Nothing -> return Nothing
 792         Just (ids, hvals) -> do
 793             vals <- (unsafeCoerce# hvals :: IO [Dynamic])
 794             case (ids,vals) of
 795                 (_:[], v:[])    -> return (Just v)
 796                 _               -> panic "dynCompileExpr"
 797
 798 -----------------------------------------------------------------------------
 799 -- show a module and it's source/object filenames
 800
 801 showModule :: Session -> ModSummary -> IO String
 802 showModule s mod_summary = withSession s $                        \hsc_env ->
 803                            isModuleInterpreted s mod_summary >>=  \interpreted ->
 804                            return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
 805
 806 isModuleInterpreted :: Session -> ModSummary -> IO Bool
 807 isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
 808   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
 809         Nothing       -> panic "missing linkable"
 810         Just mod_info -> return (not obj_linkable)
 811                       where
 812                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
 813
 814 obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
 815 obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
 816
 817 obtainTerm :: Session -> Bool -> Id -> IO Term
 818 obtainTerm sess force id = withSession sess $ \hsc_env -> do
 819               hv <- Linker.getHValue hsc_env (varName id)
 820               cvObtainTerm hsc_env force (Just$ idType id) hv
 821
 822 #endif /* GHCI */