1 -----------------------------------------------------------------------------
3 -- GHCi Interactive debugging commands
5 -- Pepe Iborra (supported by Google SoC) 2006
7 -----------------------------------------------------------------------------
13 import RtClosureInspect
19 import Var hiding ( varName )
43 import Control.Exception
45 import qualified Data.Map as Map
46 import Data.Array.Unboxed
47 import Data.Typeable ( Typeable )
54 #include "HsVersions.h"
56 -------------------------------------
57 -- | The :print & friends commands
58 -------------------------------------
59 pprintClosureCommand :: Bool -> Bool -> String -> GHCi ()
60 pprintClosureCommand bindThings force str = do
63 mbThings <- io$ ( mapM (GHC.lookupName cms) =<<)
65 . mapM (GHC.parseName cms)
67 newvarsNames <- io$ do
68 uniques <- liftM uniqsFromSupply (mkSplitUniqSupply 'q')
69 return$ map (\u-> (mkSysTvName u (mkFastString "a"))) uniques
70 let ids_ = [id | Just (AnId id) <- mbThings]
72 -- Clean up 'Unknown' types artificially injected into tyvars
73 ids = map (stripUnknowns newvarsNames) ids_
76 mb_terms <- io$ mapM (obtainTerm cms force) ids
78 -- Give names to suspensions and bind them in the local env
79 mb_terms' <- if bindThings
80 then io$ mapM (fmapMMaybe (bindSuspensions cms)) mb_terms
82 ppr_terms <- io$ mapM (fmapMMaybe (printTerm cms)) mb_terms'
83 let docs = [ ppr id <+> char '=' <+> t | (Just t,id) <- zip ppr_terms ids]
84 unqual <- io$ GHC.getPrintUnqual cms
85 io . putStrLn . showSDocForUser unqual $ Outputable.vcat docs
87 -- Type reconstruction may have obtained more defined types for some ids
88 -- So we refresh their types.
89 let new_ids0 = [ setIdType id ty | (id,Just t) <- zip ids mb_terms
90 , let Just ty = termType t
91 , ty `isMoreSpecificThan` idType id
93 new_ids <- io$ mapM (\x->liftM (setIdType x) . instantiateTyVarsToUnknown cms . idType $ x)
96 hsc_env <- io$ readIORef ref
97 let ictxt = hsc_IC hsc_env
98 type_env = ic_type_env ictxt
99 filtered_type_env = delListFromNameEnv type_env (map idName new_ids)
100 new_type_env = extendTypeEnvWithIds filtered_type_env new_ids
101 new_ic = ictxt {ic_type_env = new_type_env }
102 io$ writeIORef ref (hsc_env {hsc_IC = new_ic })
105 isMoreSpecificThan :: Type -> Type -> Bool
106 ty `isMoreSpecificThan ` ty1
107 | Just subst <- tcUnifyTys bindOnlyTy1 [repType' ty] [repType' ty1]
108 , substFiltered <- filter (not.isTyVarTy) . varEnvElts . getTvSubstEnv $ subst
109 , not . null $ substFiltered
110 , all (flip notElemTvSubst subst) ty_vars
113 where bindOnlyTy1 tyv | tyv `elem` ty_vars = AvoidMe
115 ty_vars = varSetElems$ tyVarsOfType ty
117 bindSuspensions :: Session -> Term -> IO Term
118 bindSuspensions cms@(Session ref) t = do
119 hsc_env <- readIORef ref
120 inScope <- GHC.getBindings cms
121 let ictxt = hsc_IC hsc_env
122 rn_env = ic_rn_local_env ictxt
123 type_env = ic_type_env ictxt
125 alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
126 availNames = [n | n <- map ((prefix++) . show) [1..]
127 , n `notElem` alreadyUsedNames ]
128 availNames_var <- newIORef availNames
129 (t', stuff) <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
130 let (names, tys, hvals) = unzip3 stuff
131 concrete_tys <- mapM (instantiateTyVarsToUnknown cms) tys
132 let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
133 | (name,ty) <- zip names concrete_tys]
134 new_type_env = extendTypeEnvWithIds type_env ids
135 new_rn_env = extendLocalRdrEnv rn_env names
136 new_ic = ictxt { ic_rn_local_env = new_rn_env,
137 ic_type_env = new_type_env }
138 extendLinkEnv (zip names hvals)
139 writeIORef ref (hsc_env {hsc_IC = new_ic })
143 -- Processing suspensions. Give names and recopilate info
144 nameSuspensionsAndGetInfos :: IORef [String] -> TermFold (IO (Term, [(Name,Type,HValue)]))
145 nameSuspensionsAndGetInfos freeNames = TermFold
147 fSuspension = doSuspension freeNames
148 , fTerm = \ty dc v tt -> do
150 let (terms,names) = unzip tt'
151 return (Term ty dc v terms, concat names)
152 , fPrim = \ty n ->return (Prim ty n,[])
154 doSuspension freeNames ct mb_ty hval Nothing = do
155 name <- atomicModifyIORef freeNames (\x->(tail x, head x))
156 n <- newGrimName cms name
157 let ty' = fromMaybe (error "unexpected") mb_ty
158 return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
161 -- A custom Term printer to enable the use of Show instances
162 printTerm cms@(Session ref) = customPrintTerm customPrint
164 customPrint = \p-> customPrintShowable : customPrintTermBase p
165 customPrintShowable t@Term{ty=ty, dc=dc, val=val} = do
166 let hasType = isEmptyVarSet (tyVarsOfType ty) -- redundant
167 isEvaled = isFullyEvaluatedTerm t
168 if isEvaled -- && hasType
170 hsc_env <- readIORef ref
171 dflags <- GHC.getSessionDynFlags cms
173 (new_env, bname) <- bindToFreshName hsc_env ty "showme"
174 writeIORef ref (new_env)
175 let noop_log _ _ _ _ = return ()
176 expr = "show " ++ showSDoc (ppr bname)
177 GHC.setSessionDynFlags cms dflags{log_action=noop_log}
178 mb_txt <- withExtendedLinkEnv [(bname, val)]
179 (GHC.compileExpr cms expr)
181 Just txt -> return . Just . text . unsafeCoerce# $ txt
182 Nothing -> return Nothing
184 writeIORef ref hsc_env
185 GHC.setSessionDynFlags cms dflags
188 bindToFreshName hsc_env ty userName = do
189 name <- newGrimName cms userName
190 let ictxt = hsc_IC hsc_env
191 rn_env = ic_rn_local_env ictxt
192 type_env = ic_type_env ictxt
193 id = mkGlobalId VanillaGlobal name ty vanillaIdInfo
194 new_type_env = extendTypeEnv type_env (AnId id)
195 new_rn_env = extendLocalRdrEnv rn_env [name]
196 new_ic = ictxt { ic_rn_local_env = new_rn_env,
197 ic_type_env = new_type_env }
198 return (hsc_env {hsc_IC = new_ic }, name)
199 -- Create new uniques and give them sequentially numbered names
200 -- newGrimName :: Session -> String -> IO Name
201 newGrimName cms userName = do
202 us <- mkSplitUniqSupply 'b'
203 let unique = uniqFromSupply us
204 occname = mkOccName varName userName
205 name = mkInternalName unique occname noSrcLoc
208 ----------------------------------------------------------------------------
209 -- | Replace all the tyvars in a Term with the opaque type GHC.Base.Unknown
210 ----------------------------------------------------------------------------
211 instantiateTyVarsToUnknown :: Session -> Type -> IO Type
212 instantiateTyVarsToUnknown cms ty
213 -- We have a GADT, so just fix its tyvars
214 | Just (tycon, args) <- splitTyConApp_maybe ty
217 = mapM fixTyVars args >>= return . mkTyConApp tycon
218 -- We have a regular TyCon, so map recursively to its args
219 | Just (tycon, args) <- splitTyConApp_maybe ty
221 = do unknownTyVar <- unknownTV
222 args' <- mapM (instantiateTyVarsToUnknown cms) args
223 return$ mkTyConApp tycon args'
224 -- we have a tyvar of kind *
225 | Just tyvar <- getTyVar_maybe ty
226 , ([],_) <- splitKindFunTys (tyVarKind tyvar)
228 -- we have a higher kind tyvar, so insert an unknown of the appropriate kind
229 | Just tyvar <- getTyVar_maybe ty
230 , (args,_) <- splitKindFunTys (tyVarKind tyvar)
231 = liftM mkTyConTy $ unknownTC !! length args
233 | otherwise = return ty
236 Just (ATyCon unknown_tc) <- lookupName cms unknownTyConName
237 return$ mkTyConTy unknown_tc
238 unknownTC = [undefined, unknownTC1, unknownTC2, unknownTC3]
240 Just (ATyCon unknown_tc) <- lookupName cms unknown1TyConName
243 Just (ATyCon unknown_tc) <- lookupName cms unknown2TyConName
246 Just (ATyCon unknown_tc) <- lookupName cms unknown3TyConName
248 -- isGADT ty | pprTrace' "isGADT" (ppr ty <> colon <> ppr(isGadtSyntaxTyCon ty)) False = undefined
249 isGADT tc | Just dcs <- tyConDataCons_maybe tc = any (not . null . dataConEqSpec) dcs
252 | Just (tycon, args) <- splitTyConApp_maybe ty
253 = mapM fixTyVars args >>= return . mkTyConApp tycon
254 -- Fix the tyvar so that the interactive environment doesn't choke on it TODO
255 | Just tv <- getTyVar_maybe ty = return ty --TODO
256 | otherwise = return ty
258 -- | 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
259 stripUnknowns :: [Name] -> Id -> Id
260 stripUnknowns names id = setIdType id . sigmaType . fst . go names . idType
263 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
264 go tyvarsNames@(v:vv) ty
265 | Just (ty1,ty2) <- splitFunTy_maybe ty = let
266 (ty1',vv') = go tyvarsNames ty1
267 (ty2',vv'')= go vv' ty2
268 in (mkFunTy ty1' ty2', vv'')
269 | Just (ty1,ty2) <- splitAppTy_maybe ty = let
270 (ty1',vv') = go tyvarsNames ty1
271 (ty2',vv'')= go vv' ty2
272 in (mkAppTy ty1' ty2', vv'')
273 | Just (tycon, args) <- splitTyConApp_maybe ty
274 , Just (tycon', vv') <- (fixTycon tycon tyvarsNames)
275 , (args',vv'') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
278 = (mkAppTys tycon' args',vv'')
279 | Just (tycon, args) <- splitTyConApp_maybe ty
280 , (args',vv') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
282 ([],tyvarsNames) args
283 = (mkTyConApp tycon args',vv')
284 | otherwise = (ty, tyvarsNames)
285 where fixTycon tycon (v:vv) = do
286 k <- lookup (tyConName tycon) kinds
287 return (mkTyVarTy$ mkTyVar v k, vv)
288 kinds = [ (unknownTyConName, liftedTypeKind)
289 , (unknown1TyConName, kind1)
290 , (unknown2TyConName, kind2)
291 , (unknown3TyConName, kind3)]
292 kind1 = mkArrowKind liftedTypeKind liftedTypeKind
293 kind2 = mkArrowKind kind1 liftedTypeKind
294 kind3 = mkArrowKind kind2 liftedTypeKind
295 stripUnknowns _ id = id
297 -----------------------------
298 -- | The :breakpoint command
299 -----------------------------
300 bkptOptions :: String -> GHCi ()
302 dflags <- getDynFlags
304 bkptOptions' (words cmd) bt
306 bkptOptions' ["list"] bt = do
307 let msgs = [ ppr mod <+> colon <+> ppr coords
308 | (mod,site) <- btList bt
309 , let coords = getSiteCoords bt mod site]
310 num_msgs = [parens (int n) <+> msg | (n,msg) <- zip [1..] msgs]
311 msg <- showForUser$ if null num_msgs
312 then text "There are no enabled breakpoints"
316 bkptOptions' ["stop"] bt = do
317 inside_break <- liftM not isTopLevel
318 when inside_break $ throwDyn StopChildSession
320 bkptOptions' ("add":cmds) bt
321 | [mod_name,line]<- cmds
322 , [(lineNum,[])] <- reads line
323 = handleAdd mod_name $ (\mod->addBkptByLine mod lineNum)
325 | [mod_name,line,col] <- cmds
326 = handleAdd mod_name $ (\mod->addBkptByCoord mod (read line, read col))
328 | otherwise = throwDyn $ CmdLineError $
329 "syntax: :breakpoint add Module line [col]"
331 handleAdd mod_name f = do
333 dflags <- getDynFlags
334 mod <- io$ GHC.findModule sess (GHC.mkModuleName mod_name) Nothing
335 ghciHandleDyn (handleBkptEx mod) $
337 (newTable, site) -> do
338 setBkptTable newTable
339 io (putStrLn ("Breakpoint set at " ++
340 show (getSiteCoords newTable mod site)))
342 bkptOptions' ("del":cmds) bt
344 , [(i,[])] <- reads i'
346 = if i > length bkpts
347 then throwDyn $ CmdLineError
348 "Not a valid breakpoint #. Use :breakpoint list to see the current breakpoints."
350 let (mod, site) = bkpts !! (i-1)
351 in handleDel mod $ delBkptBySite mod site
354 , [(lineNum,[])] <- reads line
355 , mod <- GHC.mkModule mainPackageId (GHC.mkModuleName fn)
356 = handleDel mod $ delBkptByLine mod lineNum
358 | [fn,line,col] <- cmds
359 , [(lineNum,[])] <- reads line
360 , [(colNum,[])] <- reads col
361 , mod <- GHC.mkModule mainPackageId (GHC.mkModuleName fn)
362 = handleDel mod $ delBkptByCoord mod (lineNum, colNum)
364 | otherwise = throwDyn $ CmdLineError $
365 "syntax: :breakpoint del (breakpoint # | Module line [col])"
367 where delMsg = "Breakpoint deleted"
368 handleDel mod f = ghciHandleDyn (handleBkptEx mod) $ do
370 newTable <- getBkptTable
372 dflags <- getDynFlags
375 bkptOptions' _ _ = throwDyn $ CmdLineError $
376 "syntax: :breakpoint (list|stop|add|del)"
379 handleBkptEx :: Module -> Debugger.BkptException -> a
380 handleBkptEx _ NoBkptFound = error "No suitable breakpoint site found"
381 -- ^ TODO Instead of complaining, set a bkpt in the next suitable line
382 handleBkptEx _ NotNeeded = error "Nothing to do"
383 handleBkptEx m NotHandled = error$ "Module " ++ showSDoc (ppr m) ++ " was not loaded under debugging mode. Enable debugging mode with -fdebugging (and reload your module)"
385 -------------------------
387 -------------------------
389 data BkptTable a = BkptTable {
390 -- | An array of breaks, indexed by site number
391 breakpoints :: Map.Map a (UArray Int Bool)
392 -- | A list of lines, each line can have zero or more sites, which are annotated with a column number
393 , sites :: Map.Map a [[(SiteNumber, Int)]]
396 sitesOf :: Ord a => BkptTable a -> a -> Maybe [[(SiteNumber, Int)]]
397 sitesOf bt fn = Map.lookup fn (sites bt)
398 bkptsOf bt fn = Map.lookup fn (breakpoints bt)
401 -- The functions for manipulating BkptTables do throw exceptions
405 | NotNeeded -- Used when a breakpoint was already enabled
408 emptyBkptTable :: Ord a => BkptTable a
409 addModule :: Ord a => a -> [(SiteNumber,Coord)] -> BkptTable a -> BkptTable a
410 -- | Lines start at index 1
411 addBkptByLine :: Ord a => a -> Int -> BkptTable a -> (BkptTable a, SiteNumber)
412 addBkptByCoord :: Ord a => a -> Coord -> BkptTable a -> (BkptTable a, SiteNumber)
413 delBkptByLine :: Ord a => a -> Int -> BkptTable a -> BkptTable a
414 delBkptBySite :: Ord a => a -> SiteNumber -> BkptTable a -> BkptTable a
415 delBkptByCoord :: Ord a => a -> Coord -> BkptTable a -> BkptTable a
417 isBkptEnabled :: Ord a => BkptTable a -> BkptLocation a -> Bool
418 btElems :: Ord a => BkptTable a -> [(a, [SiteNumber])]
419 btList :: Ord a => BkptTable a -> [BkptLocation a]
420 sitesList :: Ord a => BkptTable a -> [(a, [Coord])]
421 getSiteCoords :: Ord a => BkptTable a -> a -> SiteNumber -> Coord
423 emptyBkptTable = BkptTable Map.empty Map.empty
426 | Just lines <- sitesOf bt a
427 , Just bkptsArr <- bkptsOf bt a
430 [] -> throwDyn NoBkptFound
431 (x:_) -> let (siteNum,col) = x
432 wasAlreadyOn = bkptsArr ! siteNum
433 newArr = bkptsArr // [(siteNum, True)]
434 newTable = Map.insert a newArr (breakpoints bt)
436 then throwDyn NotNeeded
437 else (bt{breakpoints=newTable}, siteNum)
439 | Just sites <- sitesOf bt a
440 = throwDyn NoBkptFound
441 | otherwise = throwDyn NotHandled
443 addBkptByCoord a (r,c) bt
444 | Just lines <- sitesOf bt a
445 , Just bkptsArr <- bkptsOf bt a
447 = case [ (sn,col) | (sn,col)<-lines!!r, col>=c] of
448 [] -> throwDyn NoBkptFound
449 (x:_) -> let (siteNum, col) = x
450 wasAlreadyOn = bkptsArr ! siteNum
451 newArr = bkptsArr // [(siteNum, True)]
452 newTable = Map.insert a newArr (breakpoints bt)
454 then throwDyn NotNeeded
455 else (bt{breakpoints=newTable}, siteNum)
457 | Just sites <- sitesOf bt a
458 = throwDyn NoBkptFound
459 | otherwise = throwDyn NotHandled
462 | Just bkptsArr <- bkptsOf bt a
463 , not (inRange (bounds bkptsArr) i)
464 = throwDyn NoBkptFound
466 | Just bkptsArr <- bkptsOf bt a
467 , bkptsArr ! i -- Check that there was a enabled bkpt here
468 , newArr <- bkptsArr // [(i,False)]
469 , newTable <- Map.insert a newArr (breakpoints bt)
470 = bt {breakpoints=newTable}
472 | Just sites <- sitesOf bt a
475 | otherwise = throwDyn NotHandled
478 | Just sites <- sitesOf bt a
479 , (site:_) <- [s | (s,c') <- sites !! l]
480 = delBkptBySite a site bt
482 | Just sites <- sitesOf bt a
483 = throwDyn NoBkptFound
485 | otherwise = throwDyn NotHandled
487 delBkptByCoord a (r,c) bt
488 | Just sites <- sitesOf bt a
489 , (site:_) <- [s | (s,c') <- sites !! r, c>=c', isBkptEnabled bt (a,s)]
490 = delBkptBySite a site bt
492 | Just sites <- sitesOf bt a
493 = throwDyn NoBkptFound
495 | otherwise = throwDyn NotHandled
497 btElems bt = [ (a, [i | (i,True) <- assocs siteArr])
498 | (a, siteArr) <- Map.assocs (breakpoints bt) ]
500 btList bt = [(a,site) | (a, sites) <- btElems bt, site <- sites]
502 sitesList bt = [ (a, sitesCoords sitesCols) | (a, sitesCols) <- Map.assocs (sites bt) ]
503 where sitesCoords sitesCols =
505 | (row, cols) <- zip [0..] sitesCols, (_,col) <- cols ]
507 getSiteCoords bt a site
508 | Just rows <- sitesOf bt a
509 = head [ (r,c) | (r,row) <- zip [0..] rows
513 -- addModule is dumb and inefficient, but it does the job
514 addModule a [] bt = bt {sites = Map.insert a [] (sites bt)}
515 addModule a siteCoords bt
516 | nrows <- maximum$ [i | (_,(i,j)) <- siteCoords ]
517 , sitesByRow <- [ [(s,c) | (s,(r,c)) <- siteCoords, r==i]
519 , nsites <- length siteCoords
520 , initialBkpts <- listArray (1, nsites) (repeat False)
521 = bt{ sites = Map.insert a sitesByRow (sites bt)
522 , breakpoints = Map.insert a initialBkpts (breakpoints bt) }
524 isBkptEnabled bt (a,site)
525 | Just bkpts <- bkptsOf bt a
526 , inRange (bounds bkpts) site
528 | otherwise = panic "unexpected condition: I don't know that breakpoint site"
533 refreshBkptTable :: [ModSummary] -> GHCi ()
534 refreshBkptTable [] = return ()
535 refreshBkptTable (ms:mod_sums) = do
537 when isDebugging $ do
538 old_table <- getBkptTable
539 new_table <- addModuleGHC sess old_table (GHC.ms_mod ms)
540 setBkptTable new_table
541 refreshBkptTable mod_sums
542 where addModuleGHC sess bt mod = do
543 Just mod_info <- io$ GHC.getModuleInfo sess mod
544 dflags <- getDynFlags
545 let sites = GHC.modInfoBkptSites mod_info
546 io$ debugTraceMsg dflags 2
547 (ppr mod <> text ": inserted " <> int (length sites) <>
549 return$ addModule mod sites bt
550 #if defined(GHCI) && defined(DEBUGGER)
551 isDebugging = Opt_Debugging `elem` flags (GHC.ms_hspp_opts ms)