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