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