compiler/ghci/Debugger.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- GHCi Interactive debugging commands
   4 --
   5 -- Pepe Iborra (supported by Google SoC) 2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module Debugger where
  10
  11 import Linker
  12 import Breakpoints
  13 import RtClosureInspect
  14
  15 import PrelNames
  16 import HscTypes
  17 import IdInfo
  18 --import Id
  19 import Var hiding ( varName )
  20 import VarSet
  21 import VarEnv
  22 import Name
  23 import NameEnv
  24 import RdrName
  25 import Module
  26 import Finder
  27 import UniqSupply
  28 import Type
  29 import TyCon
  30 import DataCon
  31 import TcGadt
  32 import GHC
  33 import GhciMonad
  34 import PackageConfig
  35
  36 import Outputable
  37 import ErrUtils
  38 import FastString
  39 import SrcLoc
  40 import Util
  41 import Maybes
  42
  43 import Control.Exception
  44 import Control.Monad
  45 import qualified Data.Map as Map
  46 import Data.Array.Unboxed
  47 import Data.Typeable             ( Typeable )
  48 import Data.Maybe
  49 import Data.IORef
  50
  51 import System.IO
  52 import GHC.Exts
  53
  54 #include "HsVersions.h"
  55
  56 -------------------------------------
  57 -- | The :print & friends commands
  58 -------------------------------------
  59 pprintClosureCommand :: Bool -> Bool -> String -> GHCi ()
  60 pprintClosureCommand bindThings force str = do
  61   cms <- getSession
  62   let strs = words str
  63   mbThings <- io$ ( mapM (GHC.lookupName cms) =<<)
  64                   . liftM concat
  65                   . mapM (GHC.parseName cms)
  66                    $ strs
  67   newvarsNames <- io$ do
  68            uniques <- liftM uniqsFromSupply (mkSplitUniqSupply 'q')
  69            return$ map (\u-> (mkSysTvName u (mkFastString "a"))) uniques
  70   let ids_ = [id | Just (AnId id) <- mbThings]
  71
  72   -- Clean up 'Unknown' types artificially injected into tyvars
  73       ids = map (stripUnknowns newvarsNames) ids_
  74
  75  -- Obtain the terms
  76   mb_terms  <- io$ mapM (obtainTerm cms force) ids
  77
  78   -- Give names to suspensions and bind them in the local env
  79   mb_terms' <- if bindThings
  80                then io$ mapM (fmapMMaybe (bindSuspensions cms)) mb_terms
  81                else return mb_terms
  82   ppr_terms <- io$ mapM (fmapMMaybe (printTerm cms)) mb_terms'
  83   let docs = [ ppr id <+> char '=' <+> t | (Just t,id) <- zip ppr_terms ids]
  84   unqual  <- io$ GHC.getPrintUnqual cms
  85   io . putStrLn . showSDocForUser unqual $ Outputable.vcat docs
  86
  87   -- Type reconstruction may have obtained more defined types for some ids
  88   -- So we refresh their types.
  89   let new_ids0 = [ setIdType id ty | (id,Just t) <- zip ids mb_terms
  90                                    , let Just ty = termType t
  91                                    , ty `isMoreSpecificThan` idType id
  92                                    ]
  93   new_ids <- io$ mapM (\x->liftM (setIdType x) . instantiateTyVarsToUnknown cms . idType $ x)
  94                       new_ids0
  95   let Session ref = cms
  96   hsc_env <- io$ readIORef ref
  97   let ictxt = hsc_IC hsc_env
  98       type_env = ic_type_env ictxt
  99       filtered_type_env = delListFromNameEnv type_env (map idName new_ids)
 100       new_type_env =  extendTypeEnvWithIds filtered_type_env new_ids
 101       new_ic = ictxt {ic_type_env = new_type_env }
 102   io$ writeIORef ref (hsc_env {hsc_IC = new_ic })
 103
 104   where
 105     isMoreSpecificThan :: Type -> Type -> Bool
 106     ty `isMoreSpecificThan   ` ty1
 107       | Just subst    <- tcUnifyTys bindOnlyTy1 [repType' ty] [repType' ty1]
 108       , substFiltered <- filter (not.isTyVarTy) . varEnvElts . getTvSubstEnv $ subst
 109       , not . null $ substFiltered
 110       , all (flip notElemTvSubst subst) ty_vars
 111       = True
 112       | otherwise = False
 113       where bindOnlyTy1 tyv | tyv `elem` ty_vars = AvoidMe
 114                             | otherwise = BindMe
 115             ty_vars = varSetElems$ tyVarsOfType ty
 116
 117     bindSuspensions :: Session -> Term -> IO Term
 118     bindSuspensions cms@(Session ref) t = do
 119       hsc_env <- readIORef ref
 120       inScope <- GHC.getBindings cms
 121       let ictxt        = hsc_IC hsc_env
 122           rn_env       = ic_rn_local_env ictxt
 123           type_env     = ic_type_env ictxt
 124           prefix       = "_t"
 125           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
 126           availNames   = [n | n <- map ((prefix++) . show) [1..]
 127                             , n `notElem` alreadyUsedNames ]
 128       availNames_var  <- newIORef availNames
 129       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
 130       let (names, tys, hvals) = unzip3 stuff
 131       concrete_tys    <- mapM (instantiateTyVarsToUnknown cms) tys
 132       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
 133                   | (name,ty) <- zip names concrete_tys]
 134           new_type_env = extendTypeEnvWithIds type_env ids
 135           new_rn_env   = extendLocalRdrEnv rn_env names
 136           new_ic       = ictxt { ic_rn_local_env = new_rn_env,
 137                                  ic_type_env     = new_type_env }
 138       extendLinkEnv (zip names hvals)
 139       writeIORef ref (hsc_env {hsc_IC = new_ic })
 140       return t'
 141      where
 142
 143 --    Processing suspensions. Give names and recopilate info
 144         nameSuspensionsAndGetInfos :: IORef [String] -> TermFold (IO (Term, [(Name,Type,HValue)]))
 145         nameSuspensionsAndGetInfos freeNames = TermFold
 146                       {
 147                         fSuspension = doSuspension freeNames
 148                       , fTerm = \ty dc v tt -> do
 149                                     tt' <- sequence tt
 150                                     let (terms,names) = unzip tt'
 151                                     return (Term ty dc v terms, concat names)
 152                       , fPrim    = \ty n ->return (Prim ty n,[])
 153                       }
 154         doSuspension freeNames ct mb_ty hval Nothing = do
 155           name <- atomicModifyIORef freeNames (\x->(tail x, head x))
 156           n <- newGrimName cms name
 157           let ty' = fromMaybe (error "unexpected") mb_ty
 158           return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
 159
 160
 161 --  A custom Term printer to enable the use of Show instances
 162     printTerm cms@(Session ref) = customPrintTerm customPrint
 163       where
 164         customPrint = \p-> customPrintShowable : customPrintTermBase p
 165         customPrintShowable t@Term{ty=ty, dc=dc, val=val} = do
 166           let hasType = isEmptyVarSet (tyVarsOfType ty)  -- redundant
 167               isEvaled = isFullyEvaluatedTerm t
 168           if isEvaled -- && hasType
 169            then do
 170               hsc_env <- readIORef ref
 171               dflags  <- GHC.getSessionDynFlags cms
 172               do
 173                    (new_env, bname) <- bindToFreshName hsc_env ty "showme"
 174                    writeIORef ref (new_env)
 175                    let noop_log _ _ _ _ = return ()
 176                        expr = "show " ++ showSDoc (ppr bname)
 177                    GHC.setSessionDynFlags cms dflags{log_action=noop_log}
 178                    mb_txt <- withExtendedLinkEnv [(bname, val)]
 179                                (GHC.compileExpr cms expr)
 180                    case mb_txt of
 181                      Just txt -> return . Just . text . unsafeCoerce# $ txt
 182                      Nothing  -> return Nothing
 183                `finally` do
 184                    writeIORef ref hsc_env
 185                    GHC.setSessionDynFlags cms dflags
 186            else return Nothing
 187
 188         bindToFreshName hsc_env ty userName = do
 189           name <- newGrimName cms userName
 190           let ictxt    = hsc_IC hsc_env
 191               rn_env   = ic_rn_local_env ictxt
 192               type_env = ic_type_env ictxt
 193               id       = mkGlobalId VanillaGlobal name ty vanillaIdInfo
 194               new_type_env = extendTypeEnv type_env (AnId id)
 195               new_rn_env   = extendLocalRdrEnv rn_env [name]
 196               new_ic       = ictxt { ic_rn_local_env = new_rn_env,
 197                                      ic_type_env     = new_type_env }
 198           return (hsc_env {hsc_IC = new_ic }, name)
 199 --    Create new uniques and give them sequentially numbered names
 200 --    newGrimName :: Session -> String -> IO Name
 201     newGrimName cms userName  = do
 202       us <- mkSplitUniqSupply 'b'
 203       let unique  = uniqFromSupply us
 204           occname = mkOccName varName userName
 205           name    = mkInternalName unique occname noSrcLoc
 206       return name
 207
 208 ----------------------------------------------------------------------------
 209 -- | Replace all the tyvars in a Term with the opaque type GHC.Base.Unknown
 210 ----------------------------------------------------------------------------
 211 instantiateTyVarsToUnknown :: Session -> Type -> IO Type
 212 instantiateTyVarsToUnknown cms ty
 213 -- We have a GADT, so just fix its tyvars
 214     | Just (tycon, args) <- splitTyConApp_maybe ty
 215     , tycon /= funTyCon
 216     , isGADT tycon
 217     = mapM fixTyVars args >>= return . mkTyConApp tycon
 218 -- We have a regular TyCon, so map recursively to its args
 219     | Just (tycon, args) <- splitTyConApp_maybe ty
 220     , tycon /= funTyCon
 221     = do unknownTyVar <- unknownTV
 222          args' <- mapM (instantiateTyVarsToUnknown cms) args
 223          return$ mkTyConApp tycon args'
 224 -- we have a tyvar of kind *
 225     | Just tyvar <- getTyVar_maybe ty
 226     , ([],_) <- splitKindFunTys (tyVarKind tyvar)
 227     = unknownTV
 228 -- we have a higher kind tyvar, so insert an unknown of the appropriate kind
 229     | Just tyvar <- getTyVar_maybe ty
 230     , (args,_) <- splitKindFunTys (tyVarKind tyvar)
 231     = liftM mkTyConTy $ unknownTC !! length args
 232 -- Base case
 233     | otherwise    = return ty
 234
 235  where unknownTV = do
 236          Just (ATyCon unknown_tc) <- lookupName cms unknownTyConName
 237          return$ mkTyConTy unknown_tc
 238        unknownTC = [undefined, unknownTC1, unknownTC2, unknownTC3]
 239        unknownTC1 = do
 240          Just (ATyCon unknown_tc) <- lookupName cms unknown1TyConName
 241          return unknown_tc
 242        unknownTC2 = do
 243          Just (ATyCon unknown_tc) <- lookupName cms unknown2TyConName
 244          return unknown_tc
 245        unknownTC3 = do
 246          Just (ATyCon unknown_tc) <- lookupName cms unknown3TyConName
 247          return unknown_tc
 248 --       isGADT ty | pprTrace' "isGADT" (ppr ty <> colon <> ppr(isGadtSyntaxTyCon ty)) False = undefined
 249        isGADT tc | Just dcs <- tyConDataCons_maybe tc = any (not . null . dataConEqSpec) dcs
 250                  | otherwise = False
 251        fixTyVars ty
 252            | Just (tycon, args) <- splitTyConApp_maybe ty
 253            = mapM fixTyVars args >>= return . mkTyConApp tycon
 254 -- Fix the tyvar so that the interactive environment doesn't choke on it TODO
 255            | Just tv <- getTyVar_maybe ty = return ty --TODO
 256            | otherwise = return ty
 257
 258 -- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names
 259 stripUnknowns :: [Name] -> Id -> Id
 260 stripUnknowns names id = setIdType id . sigmaType . fst . go names . idType
 261                            $ id
 262  where
 263    sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
 264    go tyvarsNames@(v:vv) ty
 265     | Just (ty1,ty2) <- splitFunTy_maybe ty = let
 266                (ty1',vv') = go tyvarsNames ty1
 267                (ty2',vv'')= go vv' ty2
 268                in (mkFunTy ty1' ty2', vv'')
 269     | Just (ty1,ty2) <- splitAppTy_maybe ty = let
 270                (ty1',vv') = go tyvarsNames ty1
 271                (ty2',vv'')= go vv' ty2
 272                in (mkAppTy ty1' ty2', vv'')
 273     | Just (tycon, args) <- splitTyConApp_maybe ty
 274     , Just (tycon', vv') <- (fixTycon tycon tyvarsNames)
 275     , (args',vv'') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
 276                                              in (arg':aa,vv'))
 277                             ([],vv') args
 278     = (mkAppTys tycon' args',vv'')
 279     | Just (tycon, args) <- splitTyConApp_maybe ty
 280     , (args',vv') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
 281                                             in (arg':aa,vv'))
 282                            ([],tyvarsNames) args
 283     = (mkTyConApp tycon args',vv')
 284     | otherwise = (ty, tyvarsNames)
 285     where  fixTycon tycon (v:vv) = do
 286                k <- lookup (tyConName tycon) kinds
 287                return (mkTyVarTy$ mkTyVar v k, vv)
 288            kinds = [ (unknownTyConName, liftedTypeKind)
 289                    , (unknown1TyConName, kind1)
 290                    , (unknown2TyConName, kind2)
 291                    , (unknown3TyConName, kind3)]
 292            kind1 = mkArrowKind liftedTypeKind liftedTypeKind
 293            kind2 = mkArrowKind kind1 liftedTypeKind
 294            kind3 = mkArrowKind kind2 liftedTypeKind
 295 stripUnknowns _ id = id
 296
 297 -----------------------------
 298 -- | The :breakpoint command
 299 -----------------------------
 300 bkptOptions :: String -> GHCi Bool
 301 bkptOptions "continue" = -- We want to quit if in an inferior session
 302                          liftM not isTopLevel
 303 bkptOptions "stop" = do
 304   inside_break <- liftM not isTopLevel
 305   when inside_break $ throwDyn StopChildSession
 306   return False
 307
 308 bkptOptions cmd = do
 309   dflags <- getDynFlags
 310   bt     <- getBkptTable
 311   sess   <- getSession
 312   bkptOptions' sess (words cmd) bt
 313   return False
 314    where
 315     bkptOptions' _ ["list"] bt = do
 316       let msgs = [ ppr mod <+> colon <+> ppr coords
 317                    | (mod,site) <- btList bt
 318                    , let coords = getSiteCoords bt mod site]
 319           num_msgs = [parens (int n) <+> msg | (n,msg) <- zip [1..] msgs]
 320       msg <- showForUser$ if null num_msgs
 321                             then text "There are no enabled breakpoints"
 322                             else vcat num_msgs
 323       io$ putStrLn msg
 324
 325     bkptOptions' s ("add":cmds) bt
 326       | [mod_name,line]<- cmds
 327       , [(lineNum,[])] <- reads line
 328       =  handleAdd mod_name $ (\mod->addBkptByLine mod lineNum)
 329
 330       | [mod_name,line,col] <- cmds
 331       = handleAdd mod_name $ (\mod->addBkptByCoord mod (read line, read col))
 332
 333       | otherwise = throwDyn $ CmdLineError $
 334                        "syntax: :breakpoint add Module line [col]"
 335        where
 336          handleAdd mod_name f = do
 337            mod         <- io$ GHC.findModule s (GHC.mkModuleName mod_name) Nothing
 338            ghciHandleDyn (handleBkptEx s mod) $
 339             case f mod bt of
 340              (newTable, site)  -> do
 341                setBkptTable newTable
 342                io (putStrLn ("Breakpoint set at " ++
 343                               show (getSiteCoords newTable mod site)))
 344
 345     bkptOptions' s ("del":cmds) bt
 346       | [i']     <- cmds
 347       , [(i,[])] <- reads i'
 348       , bkpts    <- btList bt
 349       = if i > length bkpts
 350            then throwDyn $ CmdLineError
 351               "Not a valid breakpoint #. Use :breakpoint list to see the current breakpoints."
 352            else
 353              let (mod, site) = bkpts !! (i-1)
 354              in handleDel mod $ delBkptBySite mod site
 355
 356       | [fn,line]      <- cmds
 357       , [(lineNum,[])] <- reads line
 358       , mod            <- GHC.mkModule mainPackageId (GHC.mkModuleName fn)
 359       = handleDel mod $  delBkptByLine mod lineNum
 360
 361       | [fn,line,col]  <- cmds
 362       , [(lineNum,[])] <- reads line
 363       , [(colNum,[])]  <- reads col
 364       , mod            <- GHC.mkModule mainPackageId (GHC.mkModuleName fn)
 365       = handleDel mod $ delBkptByCoord mod (lineNum, colNum)
 366
 367       | otherwise = throwDyn $ CmdLineError $
 368              "syntax: :breakpoint del (breakpoint # | Module line [col])"
 369
 370        where delMsg = "Breakpoint deleted"
 371              handleDel mod f = ghciHandleDyn (handleBkptEx s mod)
 372                                              (modifyBkptTable f >> io (putStrLn delMsg))
 373
 374     bkptOptions' _ _ _ = throwDyn $ CmdLineError $
 375                          "syntax: :breakpoint (list|continue|stop|add|del)"
 376
 377 -- Error messages
 378 --    handleBkptEx :: Session -> Module -> Debugger.BkptException -> a
 379     handleBkptEx _ _ NoBkptFound = error "No suitable breakpoint site found"
 380          -- ^ TODO Instead of complaining, set a bkpt in the next suitable line
 381     handleBkptEx _ _ NotNeeded   = error "Nothing to do"
 382     handleBkptEx s m NotHandled  = io$
 383                                    findModSummary m                  >>= \mod_summary ->
 384                                    isModuleInterpreted s mod_summary >>= \it ->
 385        if it
 386         then error$ "Module " ++ showSDoc (ppr m) ++  " was not loaded under debugging mode.\n"
 387                  ++ "Enable debugging mode with -fdebugging (and reload your module)"
 388         else error$ "Module " ++ showSDoc (ppr m) ++  " was loaded in compiled (.o) mode.\n"
 389                  ++ "You must load a module in interpreted mode and with -fdebugging on to debug it."
 390                      where findModSummary m = getModuleGraph s >>= \mod_graph ->
 391                                case [ modsum | modsum <- mod_graph
 392                                              , ms_mod modsum == m ] of
 393                                  [modsum] -> return modsum
 394
 395 -------------------------
 396 -- Breakpoint Tables
 397 -------------------------
 398
 399 data BkptTable a  = BkptTable {
 400                            -- | An array of breaks, indexed by site number
 401      breakpoints :: Map.Map a (UArray Int Bool)
 402                            -- | A list of lines, each line can have zero or more sites, which are annotated with a column number
 403    , sites       :: Map.Map a [[(SiteNumber, Int)]]
 404    }
 405
 406 sitesOf :: Ord a => BkptTable a -> a -> Maybe [[(SiteNumber, Int)]]
 407 sitesOf bt fn = Map.lookup fn (sites bt)
 408 bkptsOf bt fn = Map.lookup fn (breakpoints bt)
 409
 410
 411 -- The functions for manipulating BkptTables do throw exceptions
 412 data BkptException =
 413                     NotHandled
 414                   | NoBkptFound
 415                   | NotNeeded   -- Used when a breakpoint was already enabled
 416   deriving Typeable
 417
 418 emptyBkptTable :: Ord a => BkptTable a
 419 addModule      :: Ord a => a -> [(SiteNumber,Coord)] -> BkptTable a -> BkptTable a
 420 -- | Lines start at index 1
 421 addBkptByLine  :: Ord a => a -> Int        -> BkptTable a -> (BkptTable a, SiteNumber)
 422 addBkptByCoord :: Ord a => a -> Coord      -> BkptTable a -> (BkptTable a, SiteNumber)
 423 delBkptByLine  :: Ord a => a -> Int        -> BkptTable a -> BkptTable a
 424 delBkptBySite  :: Ord a => a -> SiteNumber -> BkptTable a -> BkptTable a
 425 delBkptByCoord :: Ord a => a -> Coord      -> BkptTable a -> BkptTable a
 426
 427 isBkptEnabled  :: Ord a => BkptTable a -> BkptLocation a -> Bool
 428 btElems        :: Ord a => BkptTable a -> [(a, [SiteNumber])]
 429 btList         :: Ord a => BkptTable a -> [BkptLocation a]
 430 sitesList      :: Ord a => BkptTable a -> [(a, [Coord])]
 431 getSiteCoords  :: Ord a => BkptTable a -> a -> SiteNumber -> Coord
 432
 433 emptyBkptTable = BkptTable Map.empty Map.empty
 434
 435 addBkptByLine a i bt
 436    | Just lines    <- sitesOf bt a
 437    , Just bkptsArr <- bkptsOf bt a
 438    , i < length lines
 439    = case lines!!i of
 440        []    -> throwDyn NoBkptFound
 441        (x:_) -> let (siteNum,col) = x
 442                     wasAlreadyOn  = bkptsArr ! siteNum
 443                     newArr        = bkptsArr // [(siteNum, True)]
 444                     newTable      = Map.insert a newArr (breakpoints bt)
 445         in if wasAlreadyOn
 446            then throwDyn NotNeeded
 447            else (bt{breakpoints=newTable}, siteNum)
 448
 449    | Just sites    <- sitesOf bt a
 450    = throwDyn NoBkptFound
 451    | otherwise     = throwDyn NotHandled
 452
 453 addBkptByCoord a (r,c) bt
 454    | Just lines    <- sitesOf bt a
 455    , Just bkptsArr <- bkptsOf bt a
 456    , r < length lines
 457        = case [ (sn,col) | (sn,col)<-lines!!r, col>=c] of
 458        []    -> throwDyn NoBkptFound
 459        (x:_) -> let (siteNum, col) = x
 460                     wasAlreadyOn  = bkptsArr ! siteNum
 461                     newArr        = bkptsArr // [(siteNum, True)]
 462                     newTable      = Map.insert a newArr (breakpoints bt)
 463         in if wasAlreadyOn
 464            then throwDyn NotNeeded
 465            else (bt{breakpoints=newTable}, siteNum)
 466
 467    | Just sites    <- sitesOf bt a
 468    = throwDyn NoBkptFound
 469    | otherwise     = throwDyn NotHandled
 470
 471 delBkptBySite a i bt
 472    | Just bkptsArr <- bkptsOf bt a
 473    , not (inRange (bounds bkptsArr) i)
 474    = throwDyn NoBkptFound
 475
 476    | Just bkptsArr <- bkptsOf bt a
 477    , bkptsArr ! i     -- Check that there was a enabled bkpt here
 478    , newArr        <- bkptsArr // [(i,False)]
 479    , newTable      <- Map.insert a newArr (breakpoints bt)
 480    = bt {breakpoints=newTable}
 481
 482    | Just sites    <- sitesOf bt a
 483    = throwDyn NotNeeded
 484
 485    | otherwise = throwDyn NotHandled
 486
 487 delBkptByLine a l bt
 488    | Just sites    <- sitesOf bt a
 489    , (site:_)      <- [s | (s,c') <- sites !! l]
 490    = delBkptBySite a site bt
 491
 492    | Just sites    <- sitesOf bt a
 493    = throwDyn NoBkptFound
 494
 495    | otherwise = throwDyn NotHandled
 496
 497 delBkptByCoord a (r,c) bt
 498    | Just sites    <- sitesOf bt a
 499    , (site:_)      <- [s | (s,c') <- sites !! r, c>=c', isBkptEnabled bt (a,s)]
 500    = delBkptBySite a site bt
 501
 502    | Just sites    <- sitesOf bt a
 503    = throwDyn NoBkptFound
 504
 505    | otherwise = throwDyn NotHandled
 506
 507 btElems bt = [ (a, [i | (i,True) <- assocs siteArr])
 508              | (a, siteArr) <- Map.assocs (breakpoints bt) ]
 509
 510 btList bt =  [(a,site) | (a, sites) <- btElems bt, site <- sites]
 511
 512 sitesList bt = [ (a, sitesCoords sitesCols) | (a, sitesCols) <- Map.assocs (sites bt) ]
 513     where sitesCoords sitesCols =
 514               [ (row,col)
 515                 | (row, cols) <- zip [0..] sitesCols, (_,col) <- cols ]
 516
 517 getSiteCoords bt a site
 518    | Just rows <- sitesOf bt a
 519    = head [ (r,c) | (r,row) <- zip [0..] rows
 520                   , (s,c)   <- row
 521                   , s == site ]
 522
 523 -- addModule is dumb and inefficient, but it does the job
 524 addModule a [] bt = bt {sites = Map.insert a [] (sites bt)}
 525 addModule a siteCoords bt
 526    | nrows        <- maximum$ [i | (_,(i,j)) <- siteCoords ]
 527    , sitesByRow   <- [ [(s,c) | (s,(r,c)) <- siteCoords, r==i]
 528                        | i <- [0..nrows] ]
 529    , nsites       <- length siteCoords
 530    , initialBkpts <- listArray (1, nsites) (repeat False)
 531    = bt{ sites       = Map.insert a sitesByRow (sites bt)
 532        , breakpoints = Map.insert a initialBkpts (breakpoints bt) }
 533
 534 isBkptEnabled bt (a,site)
 535    | Just bkpts <- bkptsOf bt a
 536    , inRange (bounds bkpts) site
 537    = bkpts ! site
 538    | otherwise = panic "unexpected condition: I don't know that breakpoint site"
 539
 540 -----------------
 541 -- Other stuff
 542 -----------------
 543 refreshBkptTable :: [ModSummary] -> GHCi ()
 544 refreshBkptTable [] = return ()
 545 refreshBkptTable (ms:mod_sums) = do
 546     sess        <- getSession
 547     isDebugging <- io(isDebuggingM sess)
 548     when isDebugging $ do
 549       old_table <- getBkptTable
 550       new_table <- addModuleGHC sess old_table (GHC.ms_mod ms)
 551       setBkptTable new_table
 552     refreshBkptTable mod_sums
 553   where addModuleGHC sess bt mod = do
 554           Just mod_info <- io$ GHC.getModuleInfo sess mod
 555           dflags <- getDynFlags
 556           let sites = GHC.modInfoBkptSites mod_info
 557           io$ debugTraceMsg dflags 2
 558                 (ppr mod <> text ": inserted " <> int (length sites) <>
 559                  text " breakpoints")
 560           return$ addModule mod sites bt
 561 #if defined(GHCI) && defined(DEBUGGER)
 562         isDebuggingM sess = isModuleInterpreted sess ms >>= \isInterpreted ->
 563                             return (Opt_Debugging `elem` dflags && target == HscInterpreted && isInterpreted)
 564         dflags = flags     (GHC.ms_hspp_opts ms)
 565         target = hscTarget (GHC.ms_hspp_opts ms)
 566 #else
 567         isDebuggingM _ = return False
 568 #endif