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