Debugger.hs 22.9 KB
Newer Older
mnislaih's avatar
mnislaih committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
-----------------------------------------------------------------------------
--
-- GHCi Interactive debugging commands 
--
-- Pepe Iborra (supported by Google SoC) 2006
--
-----------------------------------------------------------------------------

module Debugger where

import Linker
import Breakpoints
import RtClosureInspect

import PrelNames
import HscTypes
import IdInfo
--import Id
import Var hiding ( varName )
import VarSet
import VarEnv
import Name 
import NameEnv
import RdrName
import Module
import Finder
import UniqSupply
import Type
import TyCon
import DataCon
import TcGadt
import GHC
import GhciMonad
import PackageConfig

import Outputable
37
import Pretty                    ( Mode(..), showDocWith )
mnislaih's avatar
mnislaih committed
38
39
40
41
import ErrUtils
import FastString
import SrcLoc
import Util
42
import Maybes
mnislaih's avatar
mnislaih committed
43
44
45
46
47

import Control.Exception
import Control.Monad
import qualified Data.Map as Map
import Data.Array.Unboxed
48
import Data.Array.Base
mnislaih's avatar
mnislaih committed
49
import Data.List
mnislaih's avatar
mnislaih committed
50
51
52
53
54
55
56
57
58
import Data.Typeable             ( Typeable )
import Data.Maybe
import Data.IORef

import System.IO
import GHC.Exts

#include "HsVersions.h"

mnislaih's avatar
mnislaih committed
59
60
61
62
-------------------------------------
-- | The :print & friends commands
-------------------------------------
pprintClosureCommand :: Bool -> Bool -> String -> GHCi ()
mnislaih's avatar
mnislaih committed
63
64
pprintClosureCommand bindThings force str = do 
  cms <- getSession
mnislaih's avatar
mnislaih committed
65
66
67
  newvarsNames <- io$ do 
           uniques <- liftM uniqsFromSupply (mkSplitUniqSupply 'q')
           return$ map (\u-> (mkSysTvName u (mkFastString "a"))) uniques
mnislaih's avatar
mnislaih committed
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
  mb_ids  <- io$ mapM (cleanUp cms newvarsNames) (words str)
  new_ids <- mapM (io . go cms) (catMaybes mb_ids)
  io$ updateIds cms new_ids
 where 
   -- Find the Id, clean up 'Unknowns'
   cleanUp :: Session -> [Name] -> String -> IO (Maybe Id)
   cleanUp cms newNames str = do
     tythings <- GHC.parseName cms str >>= mapM (GHC.lookupName cms)
     return$ listToMaybe (map (stripUnknowns newNames) 
                              [ i | Just (AnId i) <- tythings]) 

   -- Do the obtainTerm--bindSuspensions-refineIdType dance
   -- Warning! This function got a good deal of side-effects
   go :: Session -> Id -> IO Id
   go cms id = do
     Just term <- obtainTerm cms force id
     term'     <- if not bindThings then return term 
                   else bindSuspensions cms term                         
     showterm  <- pprTerm cms term'
     unqual    <- GHC.getPrintUnqual cms
88
89
90
     let showSDocForUserOneLine unqual doc = 
             showDocWith LeftMode (doc (mkErrStyle unqual))
     (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
mnislaih's avatar
mnislaih committed
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
     -- Before leaving, we compare the type obtained to see if it's more specific
     -- Note how we need the Unknown-clear type returned by obtainTerm
     let Just reconstructedType = termType term  
     new_type  <- instantiateTyVarsToUnknown cms 
                  (mostSpecificType (idType id) reconstructedType)
     return (setIdType id new_type)

   updateIds :: Session -> [Id] -> IO ()
   updateIds (Session ref) new_ids = do
     hsc_env <- readIORef ref
     let ictxt = hsc_IC hsc_env
         type_env = ic_type_env ictxt
         filtered_type_env = delListFromNameEnv type_env (map idName new_ids)
         new_type_env =  extendTypeEnvWithIds filtered_type_env new_ids
         new_ic = ictxt {ic_type_env = new_type_env }
     writeIORef ref (hsc_env {hsc_IC = new_ic })

isMoreSpecificThan :: Type -> Type -> Bool
ty `isMoreSpecificThan` ty1 
mnislaih's avatar
mnislaih committed
110
111
112
113
114
115
116
117
118
119
      | Just subst    <- tcUnifyTys bindOnlyTy1 [repType' ty] [repType' ty1] 
      , substFiltered <- filter (not.isTyVarTy) . varEnvElts . getTvSubstEnv $ subst
      , not . null $ substFiltered
      , all (flip notElemTvSubst subst) ty_vars
      = True
      | otherwise = False
      where bindOnlyTy1 tyv | tyv `elem` ty_vars = AvoidMe
                            | otherwise = BindMe
            ty_vars = varSetElems$ tyVarsOfType ty

mnislaih's avatar
mnislaih committed
120
121
122
123
124
125
126
mostSpecificType ty1 ty2 | ty1 `isMoreSpecificThan` ty2 = ty1
                         | otherwise = ty2

-- | Give names, and bind in the interactive environment, to all the suspensions
--   included (inductively) in a term
bindSuspensions :: Session -> Term -> IO Term
bindSuspensions cms@(Session ref) t = do 
mnislaih's avatar
mnislaih committed
127
128
129
130
131
132
133
      hsc_env <- readIORef ref
      inScope <- GHC.getBindings cms
      let ictxt        = hsc_IC hsc_env
          rn_env       = ic_rn_local_env ictxt
          type_env     = ic_type_env ictxt
          prefix       = "_t"
          alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
mnislaih's avatar
mnislaih committed
134
          availNames   = map ((prefix++) . show) [1..] \\ alreadyUsedNames 
mnislaih's avatar
mnislaih committed
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
      availNames_var  <- newIORef availNames
      (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
      let (names, tys, hvals) = unzip3 stuff
      concrete_tys    <- mapM (instantiateTyVarsToUnknown cms) tys
      let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
                  | (name,ty) <- zip names concrete_tys]
          new_type_env = extendTypeEnvWithIds type_env ids 
          new_rn_env   = extendLocalRdrEnv rn_env names
          new_ic       = ictxt { ic_rn_local_env = new_rn_env, 
                                 ic_type_env     = new_type_env }
      extendLinkEnv (zip names hvals)
      writeIORef ref (hsc_env {hsc_IC = new_ic })
      return t'
     where    

--    Processing suspensions. Give names and recopilate info
        nameSuspensionsAndGetInfos :: IORef [String] -> TermFold (IO (Term, [(Name,Type,HValue)]))
        nameSuspensionsAndGetInfos freeNames = TermFold 
                      {
                        fSuspension = doSuspension freeNames
                      , fTerm = \ty dc v tt -> do 
                                    tt' <- sequence tt 
                                    let (terms,names) = unzip tt' 
                                    return (Term ty dc v terms, concat names)
                      , fPrim    = \ty n ->return (Prim ty n,[])
                      }
        doSuspension freeNames ct mb_ty hval Nothing = do
          name <- atomicModifyIORef freeNames (\x->(tail x, head x))
          n <- newGrimName cms name
          let ty' = fromMaybe (error "unexpected") mb_ty
          return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])


--  A custom Term printer to enable the use of Show instances
mnislaih's avatar
mnislaih committed
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
pprTerm cms@(Session ref) = customPrintTerm customPrint
 where
  customPrint = \p-> customPrintShowable : customPrintTermBase p 
  customPrintShowable t@Term{ty=ty, dc=dc, val=val} = do
    let hasType = isEmptyVarSet (tyVarsOfType ty)  -- redundant
        isEvaled = isFullyEvaluatedTerm t
    if not isEvaled -- || not hasType
     then return Nothing
     else do 
        hsc_env <- readIORef ref
        dflags  <- GHC.getSessionDynFlags cms
        do
           (new_env, bname) <- bindToFreshName hsc_env ty "showme"
           writeIORef ref (new_env)
           let noop_log _ _ _ _ = return () 
               expr = "show " ++ showSDoc (ppr bname)
           GHC.setSessionDynFlags cms dflags{log_action=noop_log}
           mb_txt <- withExtendedLinkEnv [(bname, val)] 
                                         (GHC.compileExpr cms expr)
           case mb_txt of 
             Just txt -> return . Just . text . unsafeCoerce# $ txt
             Nothing  -> return Nothing
         `finally` do 
           writeIORef ref hsc_env
           GHC.setSessionDynFlags cms dflags
     
  bindToFreshName hsc_env ty userName = do
    name <- newGrimName cms userName 
    let ictxt    = hsc_IC hsc_env
        rn_env   = ic_rn_local_env ictxt
        type_env = ic_type_env ictxt
        id       = mkGlobalId VanillaGlobal name ty vanillaIdInfo
        new_type_env = extendTypeEnv type_env (AnId id)
        new_rn_env   = extendLocalRdrEnv rn_env [name]
        new_ic       = ictxt { ic_rn_local_env = new_rn_env, 
                               ic_type_env     = new_type_env }
    return (hsc_env {hsc_IC = new_ic }, name)

mnislaih's avatar
mnislaih committed
207
208
--    Create new uniques and give them sequentially numbered names
--    newGrimName :: Session -> String -> IO Name
mnislaih's avatar
mnislaih committed
209
210
211
212
213
214
newGrimName cms userName  = do
    us <- mkSplitUniqSupply 'b'
    let unique  = uniqFromSupply us
        occname = mkOccName varName userName
        name    = mkInternalName unique occname noSrcLoc
    return name
mnislaih's avatar
mnislaih committed
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303

----------------------------------------------------------------------------
-- | Replace all the tyvars in a Term with the opaque type GHC.Base.Unknown
----------------------------------------------------------------------------
instantiateTyVarsToUnknown :: Session -> Type -> IO Type
instantiateTyVarsToUnknown cms ty
-- We have a GADT, so just fix its tyvars
    | Just (tycon, args) <- splitTyConApp_maybe ty
    , tycon /= funTyCon
    , isGADT tycon
    = mapM fixTyVars args >>= return . mkTyConApp tycon
-- We have a regular TyCon, so map recursively to its args
    | Just (tycon, args) <- splitTyConApp_maybe ty
    , tycon /= funTyCon
    = do unknownTyVar <- unknownTV
         args' <- mapM (instantiateTyVarsToUnknown cms) args
         return$ mkTyConApp tycon args'
-- we have a tyvar of kind *
    | Just tyvar <- getTyVar_maybe ty
    , ([],_) <- splitKindFunTys (tyVarKind tyvar) 
    = unknownTV
-- we have a higher kind tyvar, so insert an unknown of the appropriate kind
    | Just tyvar <- getTyVar_maybe ty
    , (args,_) <- splitKindFunTys (tyVarKind tyvar)
    = liftM mkTyConTy $ unknownTC !! length args
-- Base case
    | otherwise    = return ty 

 where unknownTV = do 
         Just (ATyCon unknown_tc) <- lookupName cms unknownTyConName
         return$ mkTyConTy unknown_tc
       unknownTC = [undefined, unknownTC1, unknownTC2, unknownTC3]
       unknownTC1 = do 
         Just (ATyCon unknown_tc) <- lookupName cms unknown1TyConName
         return unknown_tc
       unknownTC2 = do 
         Just (ATyCon unknown_tc) <- lookupName cms unknown2TyConName
         return unknown_tc
       unknownTC3 = do 
         Just (ATyCon unknown_tc) <- lookupName cms unknown3TyConName
         return unknown_tc
--       isGADT ty | pprTrace' "isGADT" (ppr ty <> colon <> ppr(isGadtSyntaxTyCon ty)) False = undefined
       isGADT tc | Just dcs <- tyConDataCons_maybe tc = any (not . null . dataConEqSpec) dcs
                 | otherwise = False
       fixTyVars ty 
           | Just (tycon, args) <- splitTyConApp_maybe ty
           = mapM fixTyVars args >>= return . mkTyConApp tycon
-- Fix the tyvar so that the interactive environment doesn't choke on it TODO 
           | Just tv <- getTyVar_maybe ty = return ty --TODO
           | otherwise = return ty

-- | 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
stripUnknowns :: [Name] -> Id -> Id
stripUnknowns names id = setIdType id . sigmaType . fst . go names . idType 
                           $ id
 where 
   go tyvarsNames@(v:vv) ty 
    | Just (ty1,ty2) <- splitFunTy_maybe ty = let
               (ty1',vv') = go tyvarsNames ty1
               (ty2',vv'')= go vv' ty2
               in (mkFunTy ty1' ty2', vv'')
    | Just (ty1,ty2) <- splitAppTy_maybe ty = let
               (ty1',vv') = go tyvarsNames ty1
               (ty2',vv'')= go vv' ty2
               in (mkAppTy ty1' ty2', vv'')
    | Just (tycon, args) <- splitTyConApp_maybe ty 
    , Just (tycon', vv') <- (fixTycon tycon tyvarsNames)
    , (args',vv'') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg 
                                             in (arg':aa,vv'))
                            ([],vv') args
    = (mkAppTys tycon' args',vv'')
    | Just (tycon, args) <- splitTyConApp_maybe ty
    , (args',vv') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg 
                                            in (arg':aa,vv'))
                           ([],tyvarsNames) args
    = (mkTyConApp tycon args',vv')
    | otherwise = (ty, tyvarsNames)
    where  fixTycon tycon (v:vv) = do
               k <- lookup (tyConName tycon) kinds
               return (mkTyVarTy$ mkTyVar v k, vv)
           kinds = [ (unknownTyConName, liftedTypeKind)
                   , (unknown1TyConName, kind1)
                   , (unknown2TyConName, kind2)
                   , (unknown3TyConName, kind3)]
           kind1 = mkArrowKind liftedTypeKind liftedTypeKind
           kind2 = mkArrowKind kind1 liftedTypeKind
           kind3 = mkArrowKind kind2 liftedTypeKind
stripUnknowns _ id = id

mnislaih's avatar
mnislaih committed
304
305
306
-----------------------------
-- | The :breakpoint command
-----------------------------
307
308
309
310
311
312
313
314
bkptOptions :: String -> GHCi Bool
bkptOptions "continue" = -- We want to quit if in an inferior session
                         liftM not isTopLevel 
bkptOptions "stop" = do
  inside_break <- liftM not isTopLevel
  when inside_break $ throwDyn StopChildSession 
  return False

mnislaih's avatar
mnislaih committed
315
316
317
bkptOptions cmd = do 
  dflags <- getDynFlags
  bt     <- getBkptTable
318
319
  sess   <- getSession
  bkptOptions' sess (words cmd) bt
320
  return False
mnislaih's avatar
mnislaih committed
321
   where
322
    bkptOptions' _ ["list"] bt = do 
mnislaih's avatar
mnislaih committed
323
324
325
326
327
328
329
330
331
      let msgs = [ ppr mod <+> colon <+> ppr coords 
                   | (mod,site) <- btList bt
                   , let coords = getSiteCoords bt mod site]
          num_msgs = [parens (int n) <+> msg | (n,msg) <- zip [1..] msgs]
      msg <- showForUser$ if null num_msgs 
                            then text "There are no enabled breakpoints"
                            else vcat num_msgs
      io$ putStrLn msg

332
    bkptOptions' s ("add":cmds) bt 
333
334
335
336
337
338
339
      | [line]         <- cmds
      , [(lineNum,[])] <- reads line
      = do (toplevel,_) <- io$ GHC.getContext s
           case toplevel of
             (m:_) -> handleAdd (\mod->addBkptByLine mod lineNum) m
             [] -> throwDyn $ CmdLineError $ "No module loaded in debugging mode"

mnislaih's avatar
mnislaih committed
340
341
      | [mod_name,line]<- cmds
      , [(lineNum,[])] <- reads line
342
343
      = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>=
         handleAdd (\mod->addBkptByLine mod lineNum)
mnislaih's avatar
mnislaih committed
344
345

      | [mod_name,line,col] <- cmds
346
347
      = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>=
         handleAdd (\mod->addBkptByCoord mod (read line, read col))
mnislaih's avatar
mnislaih committed
348
349
350
351

      | otherwise = throwDyn $ CmdLineError $ 
                       "syntax: :breakpoint add Module line [col]"
       where 
352
         handleAdd f mod = 
mnislaih's avatar
mnislaih committed
353
354
355
           either 
             (handleBkptEx s mod)
             (\(newTable, site) -> do
mnislaih's avatar
mnislaih committed
356
357
               setBkptTable newTable 
               io (putStrLn ("Breakpoint set at " ++ 
mnislaih's avatar
mnislaih committed
358
359
                              show (getSiteCoords newTable mod site))))
             (f mod bt) 
mnislaih's avatar
mnislaih committed
360

361
    bkptOptions' s ("del":cmds) bt 
mnislaih's avatar
mnislaih committed
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
      | [i']     <- cmds 
      , [(i,[])] <- reads i'
      , bkpts    <- btList bt
      = if i > length bkpts
           then throwDyn $ CmdLineError 
              "Not a valid breakpoint #. Use :breakpoint list to see the current breakpoints."
           else 
             let (mod, site) = bkpts !! (i-1)
             in handleDel mod $ delBkptBySite mod site

      | [fn,line]      <- cmds 
      , [(lineNum,[])] <- reads line
      , mod            <- GHC.mkModule mainPackageId (GHC.mkModuleName fn)
      = handleDel mod $  delBkptByLine mod lineNum

      | [fn,line,col]  <- cmds 
      , [(lineNum,[])] <- reads line
      , [(colNum,[])]  <- reads col
      , mod            <- GHC.mkModule mainPackageId (GHC.mkModuleName fn)
      = handleDel mod $ delBkptByCoord mod (lineNum, colNum)
        
      | otherwise = throwDyn $ CmdLineError $ 
384
             "syntax: :breakpoint del (breakpoint # | [Module] line [col])"
mnislaih's avatar
mnislaih committed
385
386

       where delMsg = "Breakpoint deleted"
mnislaih's avatar
mnislaih committed
387
388
389
390
             handleDel mod f = either (handleBkptEx s mod)
                                      (\newtable-> setBkptTable newtable >> io (putStrLn delMsg))
                                      (f bt)
                                      
391
    bkptOptions' _ _ _ = throwDyn $ CmdLineError $ 
392
                         "syntax: :breakpoint (list|continue|stop|add|del)"
mnislaih's avatar
mnislaih committed
393

394
-- Error messages
395
--    handleBkptEx :: Session -> Module -> Debugger.BkptException -> a
396
397
398
    handleBkptEx s m NotHandled  = io$ do
       isInterpreted <- findModSummary m >>= isModuleInterpreted s
       if isInterpreted
399
400
401
402
        then error$ "Module " ++ showSDoc (ppr m) ++  " was not loaded under debugging mode.\n" 
                 ++ "Enable debugging mode with -fdebugging (and reload your module)"
        else error$ "Module " ++ showSDoc (ppr m) ++  " was loaded in compiled (.o) mode.\n" 
                 ++ "You must load a module in interpreted mode and with -fdebugging on to debug it."
403
404
405
         where findModSummary m = do 
                 mod_graph <- getModuleGraph s 
                 return$ head [ modsum | modsum <- mod_graph, ms_mod modsum == m]
mnislaih's avatar
mnislaih committed
406
    handleBkptEx _ _ e = error (show e)
mnislaih's avatar
mnislaih committed
407
408
409
410
411
412
413
414
415
416
417

-------------------------
-- Breakpoint Tables
-------------------------

data BkptTable a  = BkptTable { 
                           -- | An array of breaks, indexed by site number
     breakpoints :: Map.Map a (UArray Int Bool)  
                           -- | A list of lines, each line can have zero or more sites, which are annotated with a column number
   , sites       :: Map.Map a [[(SiteNumber, Int)]] 
   }
mnislaih's avatar
mnislaih committed
418
                  deriving Show
mnislaih's avatar
mnislaih committed
419
420
421
422
423
424

sitesOf :: Ord a => BkptTable a -> a -> Maybe [[(SiteNumber, Int)]] 
sitesOf bt fn = Map.lookup fn (sites bt)
bkptsOf bt fn = Map.lookup fn (breakpoints bt)


mnislaih's avatar
mnislaih committed
425
426
data BkptError =
                    NotHandled  -- Trying to manipulate a element not handled by this BkptTable 
mnislaih's avatar
mnislaih committed
427
428
429
430
                  | NoBkptFound
                  | NotNeeded   -- Used when a breakpoint was already enabled
  deriving Typeable

mnislaih's avatar
mnislaih committed
431
432
433
434
435
instance Show BkptError where
  show NoBkptFound = "No suitable breakpoint site found"
  show NotNeeded  = "Nothing to do"
  show NotHandled  = "BkptTable: Element not controlled by this table"

mnislaih's avatar
mnislaih committed
436
437
438
emptyBkptTable :: Ord a => BkptTable a
addModule      :: Ord a => a -> [(SiteNumber,Coord)] -> BkptTable a -> BkptTable a
-- | Lines start at index 1
mnislaih's avatar
mnislaih committed
439
440
441
442
443
addBkptByLine  :: Ord a => a -> Int        -> BkptTable a -> Either BkptError (BkptTable a, SiteNumber)
addBkptByCoord :: Ord a => a -> Coord      -> BkptTable a -> Either BkptError (BkptTable a, SiteNumber)
delBkptByLine  :: Ord a => a -> Int        -> BkptTable a -> Either BkptError (BkptTable a)
delBkptBySite  :: Ord a => a -> SiteNumber -> BkptTable a -> Either BkptError (BkptTable a)
delBkptByCoord :: Ord a => a -> Coord      -> BkptTable a -> Either BkptError (BkptTable a)
mnislaih's avatar
mnislaih committed
444
445
446
447
448
449
450
451
452
453
454
455
456

isBkptEnabled  :: Ord a => BkptTable a -> BkptLocation a -> Bool
btElems        :: Ord a => BkptTable a -> [(a, [SiteNumber])]
btList         :: Ord a => BkptTable a -> [BkptLocation a]
sitesList      :: Ord a => BkptTable a -> [(a, [Coord])]
getSiteCoords  :: Ord a => BkptTable a -> a -> SiteNumber -> Coord

emptyBkptTable = BkptTable Map.empty Map.empty

addBkptByLine a i bt
   | Just lines    <- sitesOf bt a
   , Just bkptsArr <- bkptsOf bt a
   , i < length lines
mnislaih's avatar
mnislaih committed
457
458
459
460
461
   = case [line | line <- drop i lines, not (null line)] of 
       ((x:_):_) -> let (siteNum,col) = x
                        wasAlreadyOn  = bkptsArr ! siteNum
                        newArr        = bkptsArr // [(siteNum, True)]
                        newTable      = Map.insert a newArr (breakpoints bt)
mnislaih's avatar
mnislaih committed
462
        in if wasAlreadyOn 
mnislaih's avatar
mnislaih committed
463
464
465
            then Left NotNeeded
            else Right (bt{breakpoints=newTable}, siteNum)
       otherwise -> Left NoBkptFound
mnislaih's avatar
mnislaih committed
466
467

   | Just sites    <- sitesOf bt a
mnislaih's avatar
mnislaih committed
468
469
   = Left NoBkptFound
   | otherwise     = Left NotHandled  
mnislaih's avatar
mnislaih committed
470
471
472
473
474
475

addBkptByCoord a (r,c) bt 
   | Just lines    <- sitesOf bt a
   , Just bkptsArr <- bkptsOf bt a
   , r < length lines
       = case [ (sn,col) | (sn,col)<-lines!!r, col>=c] of 
mnislaih's avatar
mnislaih committed
476
       []    -> Left NoBkptFound
mnislaih's avatar
mnislaih committed
477
478
479
480
481
       (x:_) -> let (siteNum, col) = x
                    wasAlreadyOn  = bkptsArr ! siteNum
                    newArr        = bkptsArr // [(siteNum, True)]
                    newTable      = Map.insert a newArr (breakpoints bt)
        in if wasAlreadyOn 
mnislaih's avatar
mnislaih committed
482
483
           then Left NotNeeded
           else Right (bt{breakpoints=newTable}, siteNum)
mnislaih's avatar
mnislaih committed
484
485

   | Just sites    <- sitesOf bt a
mnislaih's avatar
mnislaih committed
486
487
   = Left NoBkptFound
   | otherwise     = Left NotHandled  
mnislaih's avatar
mnislaih committed
488
489
490
491

delBkptBySite a i bt 
   | Just bkptsArr <- bkptsOf bt a
   , not (inRange (bounds bkptsArr) i)
mnislaih's avatar
mnislaih committed
492
   = Left NoBkptFound
mnislaih's avatar
mnislaih committed
493
494
495
496
497

   | Just bkptsArr <- bkptsOf bt a
   , bkptsArr ! i     -- Check that there was a enabled bkpt here 
   , newArr        <- bkptsArr // [(i,False)] 
   , newTable      <- Map.insert a newArr (breakpoints bt)
mnislaih's avatar
mnislaih committed
498
   = Right bt {breakpoints=newTable}
mnislaih's avatar
mnislaih committed
499
500

   | Just sites    <- sitesOf bt a
mnislaih's avatar
mnislaih committed
501
   = Left NotNeeded
mnislaih's avatar
mnislaih committed
502

mnislaih's avatar
mnislaih committed
503
   | otherwise = Left NotHandled
mnislaih's avatar
mnislaih committed
504
505
506
507
508
509
510

delBkptByLine a l bt 
   | Just sites    <- sitesOf bt a
   , (site:_)      <- [s | (s,c') <- sites !! l]
   = delBkptBySite a site bt

   | Just sites    <- sitesOf bt a
mnislaih's avatar
mnislaih committed
511
   = Left NoBkptFound
mnislaih's avatar
mnislaih committed
512

mnislaih's avatar
mnislaih committed
513
   | otherwise = Left NotHandled
mnislaih's avatar
mnislaih committed
514
515
516
517
518
519
520

delBkptByCoord a (r,c) bt 
   | Just sites    <- sitesOf bt a
   , (site:_)      <- [s | (s,c') <- sites !! r, c>=c', isBkptEnabled bt (a,s)]
   = delBkptBySite a site bt

   | Just sites    <- sitesOf bt a
mnislaih's avatar
mnislaih committed
521
   = Left NoBkptFound
mnislaih's avatar
mnislaih committed
522

mnislaih's avatar
mnislaih committed
523
   | otherwise = Left NotHandled
mnislaih's avatar
mnislaih committed
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541

btElems bt = [ (a, [i | (i,True) <- assocs siteArr])
             | (a, siteArr) <- Map.assocs (breakpoints bt) ]

btList bt =  [(a,site) | (a, sites) <- btElems bt, site <- sites] 

sitesList bt = [ (a, sitesCoords sitesCols) | (a, sitesCols) <- Map.assocs (sites bt) ]
    where sitesCoords sitesCols = 
              [ (row,col) 
                | (row, cols) <- zip [0..] sitesCols, (_,col) <- cols ] 

getSiteCoords bt a site 
   | Just rows <- sitesOf bt a
   = head [ (r,c) | (r,row) <- zip [0..] rows
                  , (s,c)   <- row
                  , s == site ]

-- addModule is dumb and inefficient, but it does the job
542
addModule a [] bt = bt {sites = Map.insert a [] (sites bt)}
mnislaih's avatar
mnislaih committed
543
544
545
546
547
addModule a siteCoords bt 
   | nrows        <- maximum$ [i | (_,(i,j)) <- siteCoords ]
   , sitesByRow   <- [ [(s,c) | (s,(r,c)) <- siteCoords, r==i] 
                       | i <- [0..nrows] ]
   , nsites       <- length siteCoords
548
   , initialBkpts <- listArray (0, nsites+1) (repeat False) 
mnislaih's avatar
mnislaih committed
549
550
551
   = bt{ sites       = Map.insert a sitesByRow (sites bt) 
       , breakpoints = Map.insert a initialBkpts (breakpoints bt) }

552
553
-- This MUST be fast
isBkptEnabled bt site | bt `seq` site `seq` False = undefined
mnislaih's avatar
mnislaih committed
554
555
isBkptEnabled bt (a,site) 
   | Just bkpts <- bkptsOf bt a 
556
557
   = ASSERT (inRange (bounds bkpts) site) 
     unsafeAt bkpts site
mnislaih's avatar
mnislaih committed
558
559
560
561

-----------------
-- Other stuff
-----------------
mnislaih's avatar
mnislaih committed
562
563
564
565
566
567
568
569
570
571
572
573
574
refreshBkptTable :: Session -> BkptTable Module -> [ModSummary] -> IO (BkptTable Module)
refreshBkptTable sess = foldM updIfDebugging
  where 
   updIfDebugging bt ms = do
      isDebugging <- isDebuggingM ms
      if isDebugging 
           then addModuleGHC sess bt (GHC.ms_mod ms)
           else return bt
   addModuleGHC sess bt mod = do
      Just mod_info <- GHC.getModuleInfo sess mod
      dflags <- GHC.getSessionDynFlags sess
      let sites = GHC.modInfoBkptSites mod_info
      debugTraceMsg dflags 2 
mnislaih's avatar
mnislaih committed
575
576
                (ppr mod <> text ": inserted " <> int (length sites) <>
                 text " breakpoints")
mnislaih's avatar
mnislaih committed
577
      return$ addModule mod sites bt
578
#if defined(GHCI) && defined(DEBUGGER)
mnislaih's avatar
mnislaih committed
579
580
581
582
583
   isDebuggingM ms = isModuleInterpreted sess ms >>= \isInterpreted -> 
                     return (Opt_Debugging `elem` dflags && 
                             target == HscInterpreted && isInterpreted)
       where dflags = flags     (GHC.ms_hspp_opts ms)
             target = hscTarget (GHC.ms_hspp_opts ms)
584
#else
mnislaih's avatar
mnislaih committed
585
   isDebuggingM _ = return False
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
586
#endif