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