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
111 -- , pprTrace "subst" (ppr subst) True
114 where bindOnlyTy1 tyv | tyv `elem` ty_vars = AvoidMe
116 ty_vars = varSetElems$ tyVarsOfType ty
118 bindSuspensions :: Session -> Term -> IO Term
119 bindSuspensions cms@(Session ref) t = do
120 hsc_env <- readIORef ref
121 inScope <- GHC.getBindings cms
122 let ictxt = hsc_IC hsc_env
123 rn_env = ic_rn_local_env ictxt
124 type_env = ic_type_env ictxt
126 alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
127 availNames = [n | n <- map ((prefix++) . show) [1..]
128 , n `notElem` alreadyUsedNames ]
129 availNames_var <- newIORef availNames
130 (t', stuff) <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
131 let (names, tys, hvals) = unzip3 stuff
132 concrete_tys <- mapM (instantiateTyVarsToUnknown cms) tys
133 let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
134 | (name,ty) <- zip names concrete_tys]
135 new_type_env = extendTypeEnvWithIds type_env ids
136 new_rn_env = extendLocalRdrEnv rn_env names
137 new_ic = ictxt { ic_rn_local_env = new_rn_env,
138 ic_type_env = new_type_env }
139 extendLinkEnv (zip names hvals)
140 writeIORef ref (hsc_env {hsc_IC = new_ic })
144 -- Processing suspensions. Give names and recopilate info
145 nameSuspensionsAndGetInfos :: IORef [String] -> TermFold (IO (Term, [(Name,Type,HValue)]))
146 nameSuspensionsAndGetInfos freeNames = TermFold
148 fSuspension = doSuspension freeNames
149 , fTerm = \ty dc v tt -> do
151 let (terms,names) = unzip tt'
152 return (Term ty dc v terms, concat names)
153 , fPrim = \ty n ->return (Prim ty n,[])
155 doSuspension freeNames ct mb_ty hval Nothing = do
156 name <- atomicModifyIORef freeNames (\x->(tail x, head x))
157 n <- newGrimName cms name
158 let ty' = fromMaybe (error "unexpected") mb_ty
159 return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
162 -- A custom Term printer to enable the use of Show instances
163 printTerm cms@(Session ref) = customPrintTerm customPrint
165 customPrint = \p-> customPrintShowable : customPrintTermBase p
166 customPrintShowable t@Term{ty=ty, dc=dc, val=val} = do
167 let hasType = isEmptyVarSet (tyVarsOfType ty) -- redundant
168 isEvaled = isFullyEvaluatedTerm t
169 if isEvaled -- && hasType
171 hsc_env <- readIORef ref
172 dflags <- GHC.getSessionDynFlags cms
174 (new_env, bname) <- bindToFreshName hsc_env ty "showme"
175 writeIORef ref (new_env)
176 let noop_log _ _ _ _ = return ()
177 expr = "show " ++ showSDoc (ppr bname)
178 GHC.setSessionDynFlags cms dflags{log_action=noop_log}
179 mb_txt <- withExtendedLinkEnv [(bname, val)]
180 (GHC.compileExpr cms expr)
182 Just txt -> return . Just . text . unsafeCoerce# $ txt
183 Nothing -> return Nothing
185 writeIORef ref hsc_env
186 GHC.setSessionDynFlags cms dflags
189 bindToFreshName hsc_env ty userName = do
190 name <- newGrimName cms userName
191 let ictxt = hsc_IC hsc_env
192 rn_env = ic_rn_local_env ictxt
193 type_env = ic_type_env ictxt
194 id = mkGlobalId VanillaGlobal name ty vanillaIdInfo
195 new_type_env = extendTypeEnv type_env (AnId id)
196 new_rn_env = extendLocalRdrEnv rn_env [name]
197 new_ic = ictxt { ic_rn_local_env = new_rn_env,
198 ic_type_env = new_type_env }
199 return (hsc_env {hsc_IC = new_ic }, name)
200 -- Create new uniques and give them sequentially numbered names
201 -- newGrimName :: Session -> String -> IO Name
202 newGrimName cms userName = do
203 us <- mkSplitUniqSupply 'b'
204 let unique = uniqFromSupply us
205 occname = mkOccName varName userName
206 name = mkInternalName unique occname noSrcLoc
209 ----------------------------------------------------------------------------
210 -- | Replace all the tyvars in a Term with the opaque type GHC.Base.Unknown
211 ----------------------------------------------------------------------------
212 instantiateTyVarsToUnknown :: Session -> Type -> IO Type
213 instantiateTyVarsToUnknown cms ty
214 -- We have a GADT, so just fix its tyvars
215 | Just (tycon, args) <- splitTyConApp_maybe ty
218 = mapM fixTyVars args >>= return . mkTyConApp tycon
219 -- We have a regular TyCon, so map recursively to its args
220 | Just (tycon, args) <- splitTyConApp_maybe ty
222 = do unknownTyVar <- unknownTV
223 args' <- mapM (instantiateTyVarsToUnknown cms) args
224 return$ mkTyConApp tycon args'
225 -- we have a tyvar of kind *
226 | Just tyvar <- getTyVar_maybe ty
227 , ([],_) <- splitKindFunTys (tyVarKind tyvar)
229 -- we have a higher kind tyvar, so insert an unknown of the appropriate kind
230 | Just tyvar <- getTyVar_maybe ty
231 , (args,_) <- splitKindFunTys (tyVarKind tyvar)
232 = liftM mkTyConTy $ unknownTC !! length args
234 | otherwise = return ty
237 Just (ATyCon unknown_tc) <- lookupName cms unknownTyConName
238 return$ mkTyConTy unknown_tc
239 unknownTC = [undefined, unknownTC1, unknownTC2, unknownTC3]
241 Just (ATyCon unknown_tc) <- lookupName cms unknown1TyConName
244 Just (ATyCon unknown_tc) <- lookupName cms unknown2TyConName
247 Just (ATyCon unknown_tc) <- lookupName cms unknown3TyConName
249 -- isGADT ty | pprTrace' "isGADT" (ppr ty <> colon <> ppr(isGadtSyntaxTyCon ty)) False = undefined
250 isGADT tc | Just dcs <- tyConDataCons_maybe tc = any (not . null . dataConEqSpec) dcs
253 | Just (tycon, args) <- splitTyConApp_maybe ty
254 = mapM fixTyVars args >>= return . mkTyConApp tycon
255 -- Fix the tyvar so that the interactive environment doesn't choke on it TODO
256 | Just tv <- getTyVar_maybe ty = return ty --TODO
257 | otherwise = return ty
259 -- | 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
260 stripUnknowns :: [Name] -> Id -> Id
261 stripUnknowns names id = setIdType id . sigmaType . fst . go names . idType
264 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
265 go tyvarsNames@(v:vv) ty
266 | Just (ty1,ty2) <- splitFunTy_maybe ty = let
267 (ty1',vv') = go tyvarsNames ty1
268 (ty2',vv'')= go vv' ty2
269 in (mkFunTy ty1' ty2', vv'')
270 | Just (ty1,ty2) <- splitAppTy_maybe ty = let
271 (ty1',vv') = go tyvarsNames ty1
272 (ty2',vv'')= go vv' ty2
273 in (mkAppTy ty1' ty2', vv'')
274 | Just (tycon, args) <- splitTyConApp_maybe ty
275 , Just (tycon', vv') <- (fixTycon tycon tyvarsNames)
276 , (args',vv'') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
279 = (mkAppTys tycon' args',vv'')
280 | Just (tycon, args) <- splitTyConApp_maybe ty
281 , (args',vv') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
283 ([],tyvarsNames) args
284 = (mkTyConApp tycon args',vv')
285 | otherwise = (ty, tyvarsNames)
286 where fixTycon tycon (v:vv) = do
287 k <- lookup (tyConName tycon) kinds
288 return (mkTyVarTy$ mkTyVar v k, vv)
289 kinds = [ (unknownTyConName, liftedTypeKind)
290 , (unknown1TyConName, kind1)
291 , (unknown2TyConName, kind2)
292 , (unknown3TyConName, kind3)]
293 kind1 = mkArrowKind liftedTypeKind liftedTypeKind
294 kind2 = mkArrowKind kind1 liftedTypeKind
295 kind3 = mkArrowKind kind2 liftedTypeKind
296 stripUnknowns _ id = id
298 -----------------------------
299 -- | The :breakpoint command
300 -----------------------------
301 bkptOptions :: String -> GHCi ()
303 dflags <- getDynFlags
305 bkptOptions' (words cmd) bt
307 bkptOptions' ["list"] bt = do
308 let msgs = [ ppr mod <+> colon <+> ppr coords
309 | (mod,site) <- btList bt
310 , let coords = getSiteCoords bt mod site]
311 num_msgs = [parens (int n) <+> msg | (n,msg) <- zip [1..] msgs]
312 msg <- showForUser$ if null num_msgs
313 then text "There are no enabled breakpoints"
317 bkptOptions' ["stop"] bt = do
318 inside_break <- liftM not isTopLevel
319 when inside_break $ throwDyn StopChildSession
321 bkptOptions' ("add":cmds) bt
322 | [mod_name,line]<- cmds
323 , [(lineNum,[])] <- reads line
324 = handleAdd mod_name $ (\mod->addBkptByLine mod lineNum)
326 | [mod_name,line,col] <- cmds
327 = handleAdd mod_name $ (\mod->addBkptByCoord mod (read line, read col))
329 | otherwise = throwDyn $ CmdLineError $
330 "syntax: :breakpoint add Module line [col]"
332 handleAdd mod_name f = do
334 dflags <- getDynFlags
335 mod <- io$ GHC.findModule sess (GHC.mkModuleName mod_name) Nothing
336 ghciHandleDyn (handleBkptEx mod) $
338 (newTable, site) -> do
339 setBkptTable newTable
340 io (putStrLn ("Breakpoint set at " ++
341 show (getSiteCoords newTable mod site)))
343 bkptOptions' ("del":cmds) bt
345 , [(i,[])] <- reads i'
347 = if i > length bkpts
348 then throwDyn $ CmdLineError
349 "Not a valid breakpoint #. Use :breakpoint list to see the current breakpoints."
351 let (mod, site) = bkpts !! (i-1)
352 in handleDel mod $ delBkptBySite mod site
355 , [(lineNum,[])] <- reads line
356 , mod <- GHC.mkModule mainPackageId (GHC.mkModuleName fn)
357 = handleDel mod $ delBkptByLine mod lineNum
359 | [fn,line,col] <- cmds
360 , [(lineNum,[])] <- reads line
361 , [(colNum,[])] <- reads col
362 , mod <- GHC.mkModule mainPackageId (GHC.mkModuleName fn)
363 = handleDel mod $ delBkptByCoord mod (lineNum, colNum)
365 | otherwise = throwDyn $ CmdLineError $
366 "syntax: :breakpoint del (breakpoint # | Module line [col])"
368 where delMsg = "Breakpoint deleted"
369 handleDel mod f = ghciHandleDyn (handleBkptEx mod) $ do
371 newTable <- getBkptTable
373 dflags <- getDynFlags
376 bkptOptions' _ _ = throwDyn $ CmdLineError $
377 "syntax: :breakpoint (list|stop|add|del)"
379 handleBkptEx :: Module -> Debugger.BkptException -> a
380 handleBkptEx _ NoBkptFound = error "No suitable breakpoint site found" --TODO Automatically add to the next suitable line
381 handleBkptEx _ NotNeeded = error "Nothing to do"
382 handleBkptEx m NotHandled = error$ "Module " ++ showSDoc (ppr m) ++ " was not loaded under debugging mode. Enable debugging mode and reload it"
384 -------------------------
386 -------------------------
388 data BkptTable a = BkptTable {
389 -- | An array of breaks, indexed by site number
390 breakpoints :: Map.Map a (UArray Int Bool)
391 -- | A list of lines, each line can have zero or more sites, which are annotated with a column number
392 , sites :: Map.Map a [[(SiteNumber, Int)]]
395 sitesOf :: Ord a => BkptTable a -> a -> Maybe [[(SiteNumber, Int)]]
396 sitesOf bt fn = Map.lookup fn (sites bt)
397 bkptsOf bt fn = Map.lookup fn (breakpoints bt)
400 -- The functions for manipulating BkptTables do throw exceptions
404 | NotNeeded -- Used when a breakpoint was already enabled
407 emptyBkptTable :: Ord a => BkptTable a
408 addModule :: Ord a => a -> [(SiteNumber,Coord)] -> BkptTable a -> BkptTable a
409 -- | Lines start at index 1
410 addBkptByLine :: Ord a => a -> Int -> BkptTable a -> (BkptTable a, SiteNumber)
411 addBkptByCoord :: Ord a => a -> Coord -> BkptTable a -> (BkptTable a, SiteNumber)
412 delBkptByLine :: Ord a => a -> Int -> BkptTable a -> BkptTable a
413 delBkptBySite :: Ord a => a -> SiteNumber -> BkptTable a -> BkptTable a
414 delBkptByCoord :: Ord a => a -> Coord -> BkptTable a -> BkptTable a
416 isBkptEnabled :: Ord a => BkptTable a -> BkptLocation a -> Bool
417 btElems :: Ord a => BkptTable a -> [(a, [SiteNumber])]
418 btList :: Ord a => BkptTable a -> [BkptLocation a]
419 sitesList :: Ord a => BkptTable a -> [(a, [Coord])]
420 getSiteCoords :: Ord a => BkptTable a -> a -> SiteNumber -> Coord
422 emptyBkptTable = BkptTable Map.empty Map.empty
425 | Just lines <- sitesOf bt a
426 , Just bkptsArr <- bkptsOf bt a
429 [] -> throwDyn NoBkptFound
430 (x:_) -> let (siteNum,col) = x
431 wasAlreadyOn = bkptsArr ! siteNum
432 newArr = bkptsArr // [(siteNum, True)]
433 newTable = Map.insert a newArr (breakpoints bt)
435 then throwDyn NotNeeded
436 else (bt{breakpoints=newTable}, siteNum)
438 | Just sites <- sitesOf bt a
439 = throwDyn NoBkptFound
440 | otherwise = throwDyn NotHandled
442 addBkptByCoord a (r,c) bt
443 | Just lines <- sitesOf bt a
444 , Just bkptsArr <- bkptsOf bt a
446 = case [ (sn,col) | (sn,col)<-lines!!r, col>=c] of
447 [] -> throwDyn NoBkptFound
448 (x:_) -> let (siteNum, col) = x
449 wasAlreadyOn = bkptsArr ! siteNum
450 newArr = bkptsArr // [(siteNum, True)]
451 newTable = Map.insert a newArr (breakpoints bt)
453 then throwDyn NotNeeded
454 else (bt{breakpoints=newTable}, siteNum)
456 | Just sites <- sitesOf bt a
457 = throwDyn NoBkptFound
458 | otherwise = throwDyn NotHandled
461 | Just bkptsArr <- bkptsOf bt a
462 , not (inRange (bounds bkptsArr) i)
463 = throwDyn NoBkptFound
465 | Just bkptsArr <- bkptsOf bt a
466 , bkptsArr ! i -- Check that there was a enabled bkpt here
467 , newArr <- bkptsArr // [(i,False)]
468 , newTable <- Map.insert a newArr (breakpoints bt)
469 = bt {breakpoints=newTable}
471 | Just sites <- sitesOf bt a
474 | otherwise = throwDyn NotHandled
477 | Just sites <- sitesOf bt a
478 , (site:_) <- [s | (s,c') <- sites !! l]
479 = delBkptBySite a site bt
481 | Just sites <- sitesOf bt a
482 = throwDyn NoBkptFound
484 | otherwise = throwDyn NotHandled
486 delBkptByCoord a (r,c) bt
487 | Just sites <- sitesOf bt a
488 , (site:_) <- [s | (s,c') <- sites !! r, c>=c', isBkptEnabled bt (a,s)]
489 = delBkptBySite a site bt
491 | Just sites <- sitesOf bt a
492 = throwDyn NoBkptFound
494 | otherwise = throwDyn NotHandled
496 btElems bt = [ (a, [i | (i,True) <- assocs siteArr])
497 | (a, siteArr) <- Map.assocs (breakpoints bt) ]
499 btList bt = [(a,site) | (a, sites) <- btElems bt, site <- sites]
501 sitesList bt = [ (a, sitesCoords sitesCols) | (a, sitesCols) <- Map.assocs (sites bt) ]
502 where sitesCoords sitesCols =
504 | (row, cols) <- zip [0..] sitesCols, (_,col) <- cols ]
506 getSiteCoords bt a site
507 | Just rows <- sitesOf bt a
508 = head [ (r,c) | (r,row) <- zip [0..] rows
512 -- addModule is dumb and inefficient, but it does the job
513 --addModule fn siteCoords _ | trace ("addModule: " ++ moduleString (unsafeCoerce# fn) ++ " - " ++ show siteCoords) False = undefined
514 addModule a [] bt = 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 = throwDyn NotHandled -- This is an error
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)