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