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