InteractiveEval.hs 37.3 KB
Newer Older
1
{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples,
2
    RecordWildCards, BangPatterns #-}
3

4 5 6 7 8 9 10 11 12 13
-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2005-2007
--
-- Running statements interactively
--
-- -----------------------------------------------------------------------------

module InteractiveEval (
#ifdef GHCI
14
        Resume(..), History(..),
15 16
        execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec,
        runDecls, runDeclsWithLocation,
17
        isStmt, hasImport, isImport, isDecl,
vivian's avatar
vivian committed
18
        parseImportDecl, SingleStep(..),
19
        resume,
20 21
        abandon, abandonAll,
        getResumeContext,
22
        getHistorySpan,
23
        getModBreaks,
24
        getHistoryModule,
25
        back, forward,
dterei's avatar
dterei committed
26
        setContext, getContext,
27
        availsToGlobalRdrEnv,
dterei's avatar
dterei committed
28 29 30 31 32 33 34 35
        getNamesInScope,
        getRdrNamesInScope,
        moduleIsInterpreted,
        getInfo,
        exprType,
        typeKind,
        parseName,
        showModule,
36
        isModuleInterpreted,
37
        parseExpr, compileParsedExpr,
dterei's avatar
dterei committed
38
        compileExpr, dynCompileExpr,
39
        compileExprRemote, compileParsedExprRemote,
40 41 42
        Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
        -- * Depcreated API (remove in GHC 7.14)
        RunResult(..), runStmt, runStmtWithLocation,
43 44 45 46 47
#endif
        ) where

#ifdef GHCI

Ian Lynagh's avatar
Ian Lynagh committed
48 49
#include "HsVersions.h"

50 51
import InteractiveEvalTypes

52 53 54
import GHCi
import GHCi.Run
import GHCi.RemoteTypes
55 56
import GhcMonad
import HscMain
57
import HsSyn
58 59
import HscTypes
import InstEnv
60
import IfaceEnv   ( newInteractiveBinder )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
61 62
import FamInstEnv ( FamInst )
import CoreFVs    ( orphNamesOfFamInst )
63
import TyCon
batterseapower's avatar
batterseapower committed
64
import Type     hiding( typeKind )
dterei's avatar
dterei committed
65
import TcType           hiding( typeKind )
66
import Var
67 68 69
import Id
import Name             hiding ( varName )
import NameSet
70
import Avail
71 72 73
import RdrName
import VarSet
import VarEnv
74
import ByteCodeTypes
75 76 77
import Linker
import DynFlags
import Unique
78
import UniqSupply
79
import MonadUtils
80
import Module
81
import PrelNames  ( toDynName, pretendNameIsInScope )
82
import Panic
83
import UniqFM
84
import Maybes
85
import ErrUtils
86 87 88
import SrcLoc
import RtClosureInspect
import Outputable
89
import FastString
90
import Bag
91
import qualified Lexer (P (..), ParseResult(..), unP, mkPState)
92
import qualified Parser (parseStmt, parseModule, parseDeclaration, parseImport)
93

94
import System.Directory
95
import Data.Dynamic
96
import Data.Either
97
import qualified Data.IntMap as IntMap
98
import Data.List (find,intercalate)
99
import StringBuffer (stringToStringBuffer)
100 101 102
import Control.Monad
import GHC.Exts
import Data.Array
103
import Exception
104 105 106 107 108
import Control.Concurrent

-- -----------------------------------------------------------------------------
-- running a statement interactively

109 110
getResumeContext :: GhcMonad m => m [Resume]
getResumeContext = withSession (return . ic_resume . hsc_IC)
111

112
mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
113
mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi)
114 115

getHistoryModule :: History -> Module
116 117
getHistoryModule = breakInfo_module . historyBreakInfo

118
getHistorySpan :: HscEnv -> History -> SrcSpan
119 120 121 122 123
getHistorySpan hsc_env History{..} =
  let BreakInfo{..} = historyBreakInfo in
  case lookupUFM (hsc_HPT hsc_env) (moduleName breakInfo_module) of
    Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number
    _ -> panic "getHistorySpan"
124

125 126
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
127
  | Just linkable <- hm_linkable hmi,
128 129
    [BCOs cbc] <- linkableUnlinked linkable
  = fromMaybe emptyModBreaks (bc_breaks cbc)
130 131 132
  | otherwise
  = emptyModBreaks -- probably object code

Simon Marlow's avatar
Simon Marlow committed
133 134 135 136
{- | Finds the enclosing top level function name -}
-- ToDo: a better way to do this would be to keep hold of the decl_path computed
-- by the coverage pass, which gives the list of lexically-enclosing bindings
-- for each tick.
Ian Lynagh's avatar
Ian Lynagh committed
137
findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
138
findEnclosingDecls hsc_env (BreakInfo modl ix) =
Ian Lynagh's avatar
Ian Lynagh committed
139
   let hmi = expectJust "findEnclosingDecls" $
140
             lookupUFM (hsc_HPT hsc_env) (moduleName modl)
141
       mb = getModBreaks hmi
142
   in modBreaks_decls mb ! ix
143

144 145 146 147 148 149
-- | Update fixity environment in the current interactive context.
updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
updateFixityEnv fix_env = do
  hsc_env <- getSession
  let ic = hsc_IC hsc_env
  setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } }
150

151 152 153 154 155 156 157 158 159
-- -----------------------------------------------------------------------------
-- execStmt

-- | default ExecOptions
execOptions :: ExecOptions
execOptions = ExecOptions
  { execSingleStep = RunToCompletion
  , execSourceFile = "<interactive>"
  , execLineNumber = 1
160
  , execWrap = EvalThis -- just run the statement, don't wrap it in anything
161 162 163 164 165 166 167 168 169
  }

-- | Run a statement in the current interactive context.
execStmt
  :: GhcMonad m
  => String             -- ^ a statement (bind or expression)
  -> ExecOptions
  -> m ExecResult
execStmt stmt ExecOptions{..} = do
170 171
    hsc_env <- getSession

172
    -- Turn off -fwarn-unused-local-binds when running a statement, to hide
173
    -- warnings about the implicit bindings we introduce.
174
    let ic       = hsc_IC hsc_env -- use the interactive dflags
175
        idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds
176
        hsc_env' = hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } }
177

dterei's avatar
dterei committed
178
    -- compile to value (IO [HValue]), don't run
179 180
    r <- liftIO $ hscStmtWithLocation hsc_env' stmt
                    execSourceFile execLineNumber
181 182

    case r of
dterei's avatar
dterei committed
183
      -- empty statement / comment
184
      Nothing -> return (ExecComplete (Right []) 0)
185

186
      Just (ids, hval, fix_env) -> do
187 188
        updateFixityEnv fix_env

189
        status <-
190
          withVirtualCWD $
191 192
            liftIO $
              evalStmt hsc_env' (isStep execSingleStep) (execWrap hval)
dterei's avatar
dterei committed
193

194
        let ic = hsc_IC hsc_env
195
            bindings = (ic_tythings ic, ic_rn_gbl_env ic)
196

197 198
            size = ghciHistSize idflags'

199
        handleRunStatus execSingleStep stmt bindings ids
200
                        status (emptyHistory size)
201

202 203 204 205 206 207 208 209 210 211 212 213 214
-- | The type returned by the deprecated 'runStmt' and
-- 'runStmtWithLocation' API
data RunResult
  = RunOk [Name]                -- ^ names bound by this evaluation
  | RunException SomeException  -- ^ statement raised an exception
  | RunBreak ThreadId [Name] (Maybe BreakInfo)

-- | Conver the old result type to the new result type
execResultToRunResult :: ExecResult -> RunResult
execResultToRunResult r =
  case r of
    ExecComplete{ execResult = Left ex } -> RunException ex
    ExecComplete{ execResult = Right names } -> RunOk names
215
    ExecBreak{..} -> RunBreak (error "no breakThreadId") breakNames breakInfo
216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234

-- Remove in GHC 7.14
{-# DEPRECATED runStmt "use execStmt" #-}
-- | Run a statement in the current interactive context.  Statement
-- may bind multple values.
runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
runStmt stmt step =
  execResultToRunResult <$> execStmt stmt execOptions { execSingleStep = step }

-- Remove in GHC 7.14
{-# DEPRECATED runStmtWithLocation "use execStmtWithLocation" #-}
runStmtWithLocation :: GhcMonad m => String -> Int ->
                       String -> SingleStep -> m RunResult
runStmtWithLocation source linenumber expr step = do
  execResultToRunResult <$>
     execStmt expr execOptions { execSingleStep = step
                               , execSourceFile = source
                               , execLineNumber = linenumber }

235 236 237
runDecls :: GhcMonad m => String -> m [Name]
runDecls = runDeclsWithLocation "<interactive>" 1

Ben Gamari's avatar
Ben Gamari committed
238 239 240
-- | Run some declarations and return any user-visible names that were brought
-- into scope.
runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
241 242 243
runDeclsWithLocation source linenumber expr =
  do
    hsc_env <- getSession
244
    (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env expr source linenumber
dterei's avatar
dterei committed
245

246 247 248 249
    setSession $ hsc_env { hsc_IC = ic }
    hsc_env <- getSession
    hsc_env' <- liftIO $ rttiEnvironment hsc_env
    modifySession (\_ -> hsc_env')
Ben Gamari's avatar
Ben Gamari committed
250
    return $ filter (not . isDerivedOccName . nameOccName)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
251
             -- For this filter, see Note [What to show to users]
Ben Gamari's avatar
Ben Gamari committed
252
           $ map getName tyThings
253

Simon Peyton Jones's avatar
Simon Peyton Jones committed
254 255 256 257 258 259 260 261 262
{- Note [What to show to users]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We don't want to display internally-generated bindings to users.
Things like the coercion axiom for newtypes. These bindings all get
OccNames that users can't write, to avoid the possiblity of name
clashes (in linker symbols).  That gives a convenient way to suppress
them. The relevant predicate is OccName.isDerivedOccName.
See Trac #11051 for more background and examples.
-}
263

264 265 266 267
withVirtualCWD :: GhcMonad m => m a -> m a
withVirtualCWD m = do
  hsc_env <- getSession

268 269 270 271 272
    -- a virtual CWD is only necessary when we're running interpreted code in
    -- the same process as the compiler.
  if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do

  let ic = hsc_IC hsc_env
273 274
  let set_cwd = do
        dir <- liftIO $ getCurrentDirectory
dterei's avatar
dterei committed
275
        case ic_cwd ic of
276 277 278 279 280 281 282 283 284 285 286 287 288
           Just dir -> liftIO $ setCurrentDirectory dir
           Nothing  -> return ()
        return dir

      reset_cwd orig_dir = do
        virt_dir <- liftIO $ getCurrentDirectory
        hsc_env <- getSession
        let old_IC = hsc_IC hsc_env
        setSession hsc_env{  hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
        liftIO $ setCurrentDirectory orig_dir

  gbracket set_cwd reset_cwd $ \_ -> m

289
parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
290
parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
291

292 293
emptyHistory :: Int -> BoundedList History
emptyHistory size = nilBL size
294

295 296
handleRunStatus :: GhcMonad m
                => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
297 298
                -> EvalStatus_ [ForeignHValue] [HValueRef]
                -> BoundedList History
299
                -> m ExecResult
300

301
handleRunStatus step expr bindings final_ids status history
302 303 304 305
  | RunAndLogSteps <- step = tracing
  | otherwise              = not_tracing
 where
  tracing
306
    | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status
307 308 309
    , not is_exception
    = do
       hsc_env <- getSession
310 311 312 313 314 315 316
       let hmi = expectJust "handleRunStatus" $
                   lookupUFM (hsc_HPT hsc_env) (mkUniqueGrimily mod_uniq)
           modl = mi_module (hm_iface hmi)
           breaks = getModBreaks hmi

       b <- liftIO $
              breakpointStatus hsc_env (modBreaks_flags breaks) ix
317 318 319 320 321
       if b
         then not_tracing
           -- This breakpoint is explicitly enabled; we want to stop
           -- instead of just logging it.
         else do
322
           apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
323 324 325
           let bi = BreakInfo modl ix
               !history' = mkHistory hsc_env apStack_fhv bi `consBL` history
                 -- history is strict, otherwise our BoundedList is pointless.
326 327
           fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
           status <- liftIO $ GHCi.resumeStmt hsc_env True fhv
328
           handleRunStatus RunAndLogSteps expr bindings final_ids
329
                           status history'
330 331 332 333 334
    | otherwise
    = not_tracing

  not_tracing
    -- Hit a breakpoint
335
    | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status
336 337
    = do
         hsc_env <- getSession
338 339
         resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
         apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
340 341 342 343 344
         let hmi = expectJust "handleRunStatus" $
                     lookupUFM (hsc_HPT hsc_env) (mkUniqueGrimily mod_uniq)
             modl = mi_module (hm_iface hmi)
             bp | is_exception = Nothing
                | otherwise = Just (BreakInfo modl ix)
345
         (hsc_env1, names, span, decl) <- liftIO $
346
           bindLocalsAtBreakpoint hsc_env apStack_fhv bp
347 348
         let
           resume = Resume
349
             { resumeStmt = expr, resumeContext = resume_ctxt_fhv
350
             , resumeBindings = bindings, resumeFinalIds = final_ids
351 352
             , resumeApStack = apStack_fhv
             , resumeBreakInfo = bp
353
             , resumeSpan = span, resumeHistory = toListBL history
354 355
             , resumeDecl = decl
             , resumeCCS = ccs
356 357
             , resumeHistoryIx = 0 }
           hsc_env2 = pushResume hsc_env1 resume
Simon Peyton Jones's avatar
Simon Peyton Jones committed
358

359
         modifySession (\_ -> hsc_env2)
360
         return (ExecBreak names bp)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
361

362
    -- Completed successfully
363
    | EvalComplete allocs (EvalSuccess hvals) <- status
364
    = do hsc_env <- getSession
365
         let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
366
             final_names = map getName final_ids
367 368 369
         liftIO $ Linker.extendLinkEnv (zip final_names hvals)
         hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
         modifySession (\_ -> hsc_env')
370
         return (ExecComplete (Right final_names) allocs)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
371

372 373 374 375
    -- Completed with an exception
    | EvalComplete alloc (EvalException e) <- status
    = return (ExecComplete (Left (fromSerializableException e)) alloc)

376
    | otherwise
377
    = panic "not_tracing" -- actually exhaustive, but GHC can't tell
378

379

380
resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
381 382 383 384
resume canLogSpan step = execResultToRunResult <$> resumeExec canLogSpan step

resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult
resumeExec canLogSpan step
385
 = do
386
   hsc_env <- getSession
387 388 389 390
   let ic = hsc_IC hsc_env
       resume = ic_resume ic

   case resume of
391 392
     [] -> liftIO $
           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
393 394 395 396
     (r:rs) -> do
        -- unbind the temporary locals by restoring the TypeEnv from
        -- before the breakpoint, and drop this Resume from the
        -- InteractiveContext.
397 398 399
        let (resume_tmp_te,resume_rdr_env) = resumeBindings r
            ic' = ic { ic_tythings = resume_tmp_te,
                       ic_rn_gbl_env = resume_rdr_env,
400
                       ic_resume   = rs }
401
        modifySession (\_ -> hsc_env{ hsc_IC = ic' })
dterei's avatar
dterei committed
402 403

        -- remove any bindings created since the breakpoint from the
404
        -- linker's environment
405 406
        let new_names = map getName (filter (`notElem` resume_tmp_te)
                                           (ic_tythings ic))
407
        liftIO $ Linker.deleteFromLinkEnv new_names
dterei's avatar
dterei committed
408 409

        case r of
410
          Resume { resumeStmt = expr, resumeContext = fhv
411
                 , resumeBindings = bindings, resumeFinalIds = final_ids
412
                 , resumeApStack = apStack, resumeBreakInfo = mb_brkpt
413
                 , resumeSpan = span
414
                 , resumeHistory = hist } -> do
415
               withVirtualCWD $ do
416
                status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv
417
                let prevHistoryLst = fromListBL 50 hist
418
                    hist' = case mb_brkpt of
419
                       Nothing -> prevHistoryLst
420
                       Just bi
421
                         | not $canLogSpan span -> prevHistoryLst
422
                         | otherwise -> mkHistory hsc_env apStack bi `consBL`
423
                                                        fromListBL 50 hist
424
                handleRunStatus step expr bindings final_ids status hist'
425

426
back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
427
back n = moveHist (+n)
428

429
forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
430
forward n = moveHist (subtract n)
431

432
moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)
433 434
moveHist fn = do
  hsc_env <- getSession
435
  case ic_resume (hsc_IC hsc_env) of
436 437
     [] -> liftIO $
           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
438 439 440 441 442
     (r:rs) -> do
        let ix = resumeHistoryIx r
            history = resumeHistory r
            new_ix = fn ix
        --
443 444 445 446
        when (new_ix > length history) $ liftIO $
           throwGhcExceptionIO (ProgramError "no more logged breakpoints")
        when (new_ix < 0) $ liftIO $
           throwGhcExceptionIO (ProgramError "already at the beginning of the history")
447 448

        let
449
          update_ic apStack mb_info = do
450 451
            (hsc_env1, names, span, decl) <-
              liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info
dterei's avatar
dterei committed
452
            let ic = hsc_IC hsc_env1
453 454
                r' = r { resumeHistoryIx = new_ix }
                ic' = ic { ic_resume = r':rs }
dterei's avatar
dterei committed
455

456
            modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
dterei's avatar
dterei committed
457

458
            return (names, new_ix, span, decl)
459 460 461 462 463

        -- careful: we want apStack to be the AP_STACK itself, not a thunk
        -- around it, hence the cases are carefully constructed below to
        -- make this the case.  ToDo: this is v. fragile, do something better.
        if new_ix == 0
dterei's avatar
dterei committed
464 465
           then case r of
                   Resume { resumeApStack = apStack,
466 467
                            resumeBreakInfo = mb_brkpt } ->
                          update_ic apStack mb_brkpt
dterei's avatar
dterei committed
468
           else case history !! (new_ix - 1) of
469 470 471
                   History{..} ->
                     update_ic historyApStack (Just historyBreakInfo)

472 473 474

-- -----------------------------------------------------------------------------
-- After stopping at a breakpoint, add free variables to the environment
475

476
result_fs :: FastString
477
result_fs = fsLit "_result"
478

479 480
bindLocalsAtBreakpoint
        :: HscEnv
481
        -> ForeignHValue
482
        -> Maybe BreakInfo
483
        -> IO (HscEnv, [Name], SrcSpan, String)
484 485 486 487 488 489

-- Nothing case: we stopped when an exception was raised, not at a
-- breakpoint.  We have no location information or local variables to
-- bind, all we can do is bind a local variable to the exception
-- value.
bindLocalsAtBreakpoint hsc_env apStack Nothing = do
490
   let exn_occ = mkVarOccFS (fsLit "_exception")
491
       span    = mkGeneralSrcSpan (fsLit "<unknown>")
492 493 494 495 496 497
   exn_name <- newInteractiveBinder hsc_env exn_occ span

   let e_fs    = fsLit "e"
       e_name  = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
       e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind
       exn_id  = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
498 499

       ictxt0 = hsc_IC hsc_env
500
       ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
501
   --
502
   Linker.extendLinkEnv [(exn_name, apStack)]
503
   return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
504 505 506

-- Just case: we stopped at a breakpoint, we have information about the location
-- of the breakpoint and the free variables of the expression.
507
bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
dterei's avatar
dterei committed
508 509
   let
       hmi       = expectJust "bindLocalsAtBreakpoint" $
510
                     lookupUFM (hsc_HPT hsc_env) (moduleName breakInfo_module)
511
       breaks    = getModBreaks hmi
512 513 514 515 516 517 518
       info      = expectJust "bindLocalsAtBreakpoint2" $
                     IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)
       vars      = cgb_vars info
       result_ty = cgb_resty info
       occs      = modBreaks_vars breaks ! breakInfo_number
       span      = modBreaks_locs breaks ! breakInfo_number
       decl      = intercalate "." $ modBreaks_decls breaks ! breakInfo_number
519

520 521 522
           -- Filter out any unboxed ids;
           -- we can't bind these at the prompt
       pointers = filter (\(id,_) -> isPointer id) vars
523 524 525
       isPointer id | UnaryRep ty <- repType (idType id)
                    , PtrRep <- typePrimRep ty = True
                    | otherwise                = False
526

527 528
       (ids, offsets) = unzip pointers

529 530
       free_tvs = mapUnionVarSet (tyCoVarsOfType . idType) ids
                  `unionVarSet` tyCoVarsOfType result_ty
531 532 533 534 535

   -- It might be that getIdValFromApStack fails, because the AP_STACK
   -- has been accidentally evaluated, or something else has gone wrong.
   -- So that we don't fall over in a heap when this happens, just don't
   -- bind any free variables instead, and we emit a warning.
536 537
   mb_hValues <-
      mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets
538 539
   when (any isNothing mb_hValues) $
      debugTraceMsg (hsc_dflags hsc_env) 1 $
dterei's avatar
dterei committed
540
          text "Warning: _result has been evaluated, some bindings have been lost"
541

542 543 544 545
   us <- mkSplitUniqSupply 'I'   -- Dodgy; will give the same uniques every time
   let tv_subst     = newTyVars us free_tvs
       filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
       (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $
546
                      map (substTy tv_subst . idType) filtered_ids
547 548 549 550

   new_ids     <- zipWith3M mkNewId occs tidy_tys filtered_ids
   result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span

551
   let result_id = Id.mkVanillaGlobal result_name
552
                     (substTy tv_subst result_ty)
553 554 555 556
       result_ok = isPointer result_id

       final_ids | result_ok = result_id : new_ids
                 | otherwise = new_ids
mnislaih's avatar
mnislaih committed
557
       ictxt0 = hsc_IC hsc_env
558
       ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
559
       names  = map idName new_ids
560

561
   let fhvs = catMaybes mb_hValues
562 563
   Linker.extendLinkEnv (zip names fhvs)
   when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]
mnislaih's avatar
mnislaih committed
564
   hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
565
   return (hsc_env1, if result_ok then result_name:names else names, span, decl)
566
  where
567
        -- We need a fresh Unique for each Id we bind, because the linker
568 569 570
        -- state is single-threaded and otherwise we'd spam old bindings
        -- whenever we stop at a breakpoint.  The InteractveContext is properly
        -- saved/restored, but not the linker state.  See #1743, test break026.
571 572 573 574
   mkNewId :: OccName -> Type -> Id -> IO Id
   mkNewId occ ty old_id
     = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)
          ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }
575

576
   newTyVars :: UniqSupply -> TcTyVarSet -> TCvSubst
577 578 579
     -- Similarly, clone the type variables mentioned in the types
     -- we have here, *and* make them all RuntimeUnk tyars
   newTyVars us tvs
niteria's avatar
niteria committed
580 581 582
     = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
                    | (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us
                    , let name = setNameUnique (tyVarName tv) uniq ]
583

dterei's avatar
dterei committed
584
rttiEnvironment :: HscEnv -> IO HscEnv
mnislaih's avatar
mnislaih committed
585
rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
586
   let tmp_ids = [id | AnId id <- ic_tythings ic]
dterei's avatar
dterei committed
587
       incompletelyTypedIds =
mnislaih's avatar
mnislaih committed
588
           [id | id <- tmp_ids
pepe's avatar
pepe committed
589
               , not $ noSkolems id
mnislaih's avatar
mnislaih committed
590
               , (occNameFS.nameOccName.idName) id /= result_fs]
pepe's avatar
pepe committed
591 592 593
   hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
   return hsc_env'
    where
594
     noSkolems = isEmptyVarSet . tyCoVarsOfType . idType
pepe's avatar
pepe committed
595
     improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
596
      let tmp_ids = [id | AnId id <- ic_tythings ic]
pepe's avatar
pepe committed
597 598 599 600 601 602 603 604 605
          Just id = find (\i -> idName i == name) tmp_ids
      if noSkolems id
         then return hsc_env
         else do
           mb_new_ty <- reconstructType hsc_env 10 id
           let old_ty = idType id
           case mb_new_ty of
             Nothing -> return hsc_env
             Just new_ty -> do
606
              case improveRTTIType hsc_env old_ty new_ty of
pepe's avatar
pepe committed
607 608 609 610
               Nothing -> return $
                        WARN(True, text (":print failed to calculate the "
                                           ++ "improvement for a type")) hsc_env
               Just subst -> do
611
                 let dflags = hsc_dflags hsc_env
612
                 when (dopt Opt_D_dump_rtti dflags) $
613
                      printInfoForUser dflags alwaysQualify $
pepe's avatar
pepe committed
614 615
                      fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]

616
                 let ic' = substInteractiveContext ic subst
pepe's avatar
pepe committed
617 618
                 return hsc_env{hsc_IC=ic'}

619 620 621 622 623 624 625 626 627
pushResume :: HscEnv -> Resume -> HscEnv
pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
  where
        ictxt0 = hsc_IC hsc_env
        ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }

-- -----------------------------------------------------------------------------
-- Abandoning a resume context

628 629 630
abandon :: GhcMonad m => m Bool
abandon = do
   hsc_env <- getSession
631 632 633 634
   let ic = hsc_IC hsc_env
       resume = ic_resume ic
   case resume of
      []    -> return False
dterei's avatar
dterei committed
635
      r:rs  -> do
636
         modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
637
         liftIO $ abandonStmt hsc_env (resumeContext r)
638 639
         return True

640 641 642
abandonAll :: GhcMonad m => m Bool
abandonAll = do
   hsc_env <- getSession
643 644 645
   let ic = hsc_IC hsc_env
       resume = ic_resume ic
   case resume of
646
      []  -> return False
dterei's avatar
dterei committed
647
      rs  -> do
648
         modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
649
         liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs
650 651 652 653 654 655 656 657 658 659 660
         return True

-- -----------------------------------------------------------------------------
-- Bounded list, optimised for repeated cons

data BoundedList a = BL
                        {-# UNPACK #-} !Int  -- length
                        {-# UNPACK #-} !Int  -- bound
                        [a] -- left
                        [a] -- right,  list is (left ++ reverse right)

661 662 663
nilBL :: Int -> BoundedList a
nilBL bound = BL 0 bound [] []

664
consBL :: a -> BoundedList a -> BoundedList a
665 666
consBL a (BL len bound left right)
  | len < bound = BL (len+1) bound (a:left) right
667 668
  | null right  = BL len     bound [a]      $! tail (reverse left)
  | otherwise   = BL len     bound (a:left) $! tail right
669

670
toListBL :: BoundedList a -> [a]
671 672
toListBL (BL _ _ left right) = left ++ reverse right

673
fromListBL :: Int -> [a] -> BoundedList a
674 675
fromListBL bound l = BL (length l) bound l []

676
-- lenBL (BL len _ _ _) = len
677 678 679 680

-- -----------------------------------------------------------------------------
-- | Set the interactive evaluation context.
--
Simon Peyton Jones's avatar
Simon Peyton Jones committed
681 682
-- (setContext imports) sets the ic_imports field (which in turn
-- determines what is in scope at the prompt) to 'imports', and
Gabor Greif's avatar
Gabor Greif committed
683
-- constructs the ic_rn_glb_env environment to reflect it.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
684 685 686 687
--
-- We retain in scope all the things defined at the prompt, and kept
-- in ic_tythings.  (Indeed, they shadow stuff from ic_imports.)

688 689 690
setContext :: GhcMonad m => [InteractiveImport] -> m ()
setContext imports
  = do { hsc_env <- getSession
Ian Lynagh's avatar
Ian Lynagh committed
691
       ; let dflags = hsc_dflags hsc_env
692 693
       ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
       ; case all_env_err of
694 695
           Left (mod, err) ->
               liftIO $ throwGhcExceptionIO (formatError dflags mod err)
696
           Right all_env -> do {
697
       ; let old_ic        = hsc_IC hsc_env
698
             final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic
699
       ; modifySession $ \_ ->
700
         hsc_env{ hsc_IC = old_ic { ic_imports    = imports
701 702
                                  , ic_rn_gbl_env = final_rdr_env }}}}
  where
Ian Lynagh's avatar
Ian Lynagh committed
703
    formatError dflags mod err = ProgramError . showSDoc dflags $
704 705
      text "Cannot add module" <+> ppr mod <+>
      text "to context:" <+> text err
706

707 708
findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
                 -> IO (Either (ModuleName, String) GlobalRdrEnv)
709 710
-- Compute the GlobalRdrEnv for the interactive context
findGlobalRdrEnv hsc_env imports
711
  = do { idecls_env <- hscRnImportDecls hsc_env idecls
dterei's avatar
dterei committed
712
                    -- This call also loads any orphan modules
713 714
       ; return $ case partitionEithers (map mkEnv imods) of
           ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
715
           (err : _, _)    -> Left err }
716 717 718 719
  where
    idecls :: [LImportDecl RdrName]
    idecls = [noLoc d | IIDecl d <- imports]

720
    imods :: [ModuleName]
721 722
    imods = [m | IIModule m <- imports]

723 724 725 726
    mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of
      Left err -> Left (mod, err)
      Right env -> Right env

727 728
availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
availsToGlobalRdrEnv mod_name avails
729
  = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)
730
  where
731 732
      -- We're building a GlobalRdrEnv as if the user imported
      -- all the specified modules into the global interactive module
733
    imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
dterei's avatar
dterei committed
734 735 736
    decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
                         is_qual = False,
                         is_dloc = srcLocSpan interactiveSrcLoc }
737

738
mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
739
mkTopLevEnv hpt modl
740
  = case lookupUFM hpt modl of
741
      Nothing -> Left "not a home module"
742
      Just details ->
dterei's avatar
dterei committed
743
         case mi_globals (hm_iface details) of
744 745
                Nothing  -> Left "not interpreted"
                Just env -> Right env
746 747 748 749

-- | Get the interactive evaluation context, consisting of a pair of the
-- set of modules from which we take the full top-level scope, and the set
-- of modules from which we take just the exports respectively.
750
getContext :: GhcMonad m => m [InteractiveImport]
751
getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
752
             return (ic_imports ic)
753

754
-- | Returns @True@ if the specified module is interpreted, and hence has
755
-- its full top-level scope available.
756 757
moduleIsInterpreted :: GhcMonad m => Module -> m Bool
moduleIsInterpreted modl = withSession $ \h ->
758
 if moduleUnitId modl /= thisPackage (hsc_dflags h)
759 760 761 762 763 764
        then return False
        else case lookupUFM (hsc_HPT h) (moduleName modl) of
                Just details       -> return (isJust (mi_globals (hm_iface details)))
                _not_a_home_module -> return False

-- | Looks up an identifier in the current interactive context (for :info)
dterei's avatar
dterei committed
765
-- Filter the instances by the ones whose tycons (or clases resp)
766 767
-- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
-- The exact choice of which ones to show, and which to hide, is a judgement call.
dterei's avatar
dterei committed
768
--      (see Trac #1581)
769
getInfo :: GhcMonad m => Bool -> Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst]))
770
getInfo allInfo name
771
  = withSession $ \hsc_env ->
772
    do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
Thomas Schilling's avatar
Thomas Schilling committed
773 774
       case mb_stuff of
         Nothing -> return Nothing
775
         Just (thing, fixity, cls_insts, fam_insts) -> do
Thomas Schilling's avatar
Thomas Schilling committed
776
           let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
777 778 779 780 781 782

           -- Filter the instances based on whether the constituent names of their
           -- instance heads are all in scope.
           let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts
               fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts
           return (Just (thing, fixity, cls_insts', fam_insts'))
783
  where
784
    plausible rdr_env names
785 786
          -- Dfun involving only names that are in ic_rn_glb_env
        = allInfo
787
       || all ok (nameSetElems names)
dterei's avatar
dterei committed
788 789
        where   -- A name is ok if it's in the rdr_env,
                -- whether qualified or not
790 791 792 793 794 795 796
          ok n | n == name              = True
                       -- The one we looked for in the first place!
               | pretendNameIsInScope n = True
               | isBuiltInSyntax n      = True
               | isExternalName n       = any ((== n) . gre_name)
                                              (lookupGRE_Name rdr_env n)
               | otherwise              = True
797 798

-- | Returns all names in scope in the current interactive context
799 800
getNamesInScope :: GhcMonad m => m [Name]
getNamesInScope = withSession $ \hsc_env -> do
801 802
  return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))

Thomas Schilling's avatar